批量提取行数不定的word表格信息

yuhan4488

各位老师，从word表格中提取信息，
不同文件的表格结构基本一致，唯独就是行数不一致。
第2行（包括第2行）以下的都是信息行，把每个word文件中的信息提取到excel中为一行
有的word文件（附件1班）信息行是5行，
有的word文件（附件2班）信息行是3行，
有的word文件（附件3班）信息行是4行。
以上附件是举例，实际可能信息行会更多，比如几百行。
遇到的问题是：
如何把不同行数的word表信息提取到excel中？
代码中如何引入变量？

liulang0808

r = 1
            For i = 2 To 6
                For j = 1 To 4
                    r = r + 1
                    arr(n, r) = .Tables(1).Cell(i, j).Range
                Next j
            Next i
看看红框部分，修改成这样是否可行吧

小花鹿

先判断表格行数，再循环

yuhan4488

1. Sub 提取word信息()
   
2.     Sheet1.Cells.ClearContents
   
3.     Dim fso, fp, arr, wd, f, n%, fname$
   
4.     Set fso = CreateObject("scripting.filesystemobject")
   
5.     Set fp = fso.GetFolder(ThisWorkbook.Path)
   
6.     ReDim arr(1 To 1000, 1 To 100)
   
7.     Set wd = CreateObject("word.application")
   
8.     n = 0
   
9.     For Each f In fp.Files
   
10.         If Right(f, 3) = "doc" Or Right(f, 4) = "docx" Then
    
11.         n = n + 1:
    
12.         arr(n, 1) = fso.getbasename(f)
    
13.         fname = fso.getfilename(f)
    
14.         With wd.Documents.Open(ThisWorkbook.Path & "" & fname, True, True)
    
15.             wd.Visible = True
    
16.             
    
17.             r = 1
    
18.             For i = 2 To 6
    
19.                 For j = 1 To 4
    
20.                     r = r + 1
    
21.                     arr(n, r) = .Tables(1).Cell(i, j).Range
    
22.                 Next j
    
23.             Next i
    
24.                   
    
25.         .Close
    
26.         End With
    
27.         End If
    
28.         Next
    
29.         wd.Quit
    
30.     Sheets(1).[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
31.     ActiveSheet.UsedRange.Replace "", ""
    
32.     ActiveSheet.UsedRange.NumberFormatLocal = "@"
    
33. 
    
34. End Sub

复制代码

liulang0808老师，您好。非常感谢您的指导。您的代码基本上解决了变量的问题。
但是因为不同word文件表格行数不定，代码和提取结果还存在2个问题：
1.代码中的word最大行（”For i = 2 To 6“的6），如何实现自动化获取？
如何在不同表格行的word文件中自动获取到最大行值的信息？
2.提取结果中最大行的word提取信息正确。但是小于最大行的word文件提取的信息，则用最后一行数据补齐到最大行的数据列。
比如在例子中最大行是6的word信息提取正确，但是5行和4行的word文件用最后一行数据补齐到6行，多出来这些补齐的数据。

云南邦盈顾问

For i = 2 To .Tables(1).Rows.Count
    For j = 1 To .Tables(1).Columns.Count

yuhan4488

经过“liulang0808”老师、“小花鹿”老师和“云南邦盈顾问”老师三位老师的指导，问题完美解决，感谢三位老师。以下是三位老师指导后的代码，分享：


Sub 提取word信息()
     Sheet1.Cells.ClearContents
     Dim fso, fp, arr, wd, f, n%, fname$
    Set fso = CreateObject("scripting.filesystemobject")
    Set fp = fso.getfolder(ThisWorkbook.Path)
    ReDim arr(1 To 1000, 1 To 100)
    Set wd = CreateObject("word.application")
    n = 0
    For Each f In fp.Files
        If Right(f, 3) = "doc" Or Right(f, 4) = "docx" Then
        n = n + 1:
        arr(n, 1) = fso.getbasename(f)
        fname = fso.getfilename(f)
        With wd.Documents.Open(ThisWorkbook.Path & "\" & fname, True, True)
            wd.Visible = True
            
           r = 1
           For i = 2 To .Tables(1).Rows.Count
           For j = 1 To .Tables(1).Columns.Count
                    r = r + 1
                    arr(n, r) = .Tables(1).Cell(i, j).Range
                Next j
            Next i
            
        .Close
        End With
        End If
        Next
        wd.Quit

    Sheets(1).[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    ActiveSheet.UsedRange.Replace "", ""
    ActiveSheet.UsedRange.NumberFormatLocal = "@"
End Sub

捞屎人

liulang0808 发表于 2022-11-27 21:53
r = 1
            For i = 2 To 6
                For j = 1 To 4

最近正在研究 word  vba  你真是厉害

newlove

yuhan4488 发表于 2022-11-28 11:56
经过“liulang0808”老师、“小花鹿”老师和“云南邦盈顾问”老师三位老师的指导，问题完美解决，感谢三位 ...

麻烦放一个完整的附件

yuhan4488

好的，我放一个修改后完整的附件

gphyn123

太厉害了，学习到了。