Excel VBA：遍历所有单词文档并提取表格数据？

Question

问题编辑：

我有多个Word文档的文件夹（在DOCX和DOC格式）：

Word Doc 1 
Word Doc 2 
Word Doc 3 
etc. 

目前，我在Excel中的VBA代码，通过word文档和提取物循环所有的表格数据放入我的电子表格中。

代码：

Sub ImportWordTable() 
'On Error Resume Next 
Application.ScreenUpdating = False 
Application.DisplayAlerts = False 


Dim oWordApp As Word.Application 
Dim wdDoc As Word.Document 
Dim MyFile As String 
Dim wdFileName As Variant 
Dim TableNo As Integer 'table number in Word 
Dim iRow As Long 'row index in Excel 
Dim iCol As Integer 'column index in Excel 
Dim i As Long 
Dim r As Long, c As Long 
Dim vDirectory As String 


Set objWord = CreateObject("Word.Application") 


'Start my loop 

    vDirectory = "G:\QUALITY ASSURANCE\03_AUDITS\PAI\Audit Feedback\Audit Feedback " & Worksheets(1).Range("B9").Value & "\" 

    vFile = Dir(vDirectory & "*.doc*") 

    Do While vFile <> "" 

     Set wdDoc = Documents.Open(filename:=vDirectory & vFile, ReadOnly:=True) 

     r = 1 
     c = 1 

     With wdDoc 
TableNo = wdDoc.tables.Count 
    If .tables.Count > 0 Then 
     For i = 1 To TableNo 
      With .tables(i) 
       'copy cell contents from Word table cells to Excel cells 
       For iRow = 1 To .Rows.Count 
        For iCol = 1 To .Columns.Count 
         Worksheets("Data").Cells(r, c) = Trim(WorksheetFunction.Clean(Replace(Replace(.cell(iRow, iCol).Range.Text, Chr(13), " "), Chr(10), ""))) 
         c = c + 1 
        Next iCol 
        c = 1 
        r = r + 1 
       Next iRow 
      End With 
      c = 1 
     Next i 
    End If 
End With 

     wdDoc.Close SaveChanges:=False 
     vFile = Dir 
    Loop 

Application.ScreenUpdating = True 
Application.DisplayAlerts = True 

End Sub 

然而，从每个文档中的数据正在由下覆盖。我没有错误！

相反，代码应与其他类似打完名单下跌电子表格一个所有数据：

Excel电子表格的结果：（每蓝亮的行是从每个字文档的新数据的开头）

请有人告诉我最好的方法来做到这一点？首先十分感谢。

Answer 1

我设法解决了这个问题。我并没有严格的定义我iRow变量：

Sub ImportWordTable() 
'On Error Resume Next 
'Application.ScreenUpdating = False 
'Application.DisplayAlerts = False 


Dim oWordApp As Word.Application 
Dim wdDoc As Word.Document 
Dim MyFile As String 
Dim wdFileName As Variant 
Dim TableNo As Integer 'table number in Word 
Dim iRow As Long 'row index in Excel 
Dim iCol As Integer 'column index in Excel 
Dim i As Long 
Dim r As Long, c As Long 
Dim vDirectory As String 
Dim lastrow As Long 

Set objWord = CreateObject("Word.Application") 
lastrow = ThisWorkbook.Worksheets("Data").Range("A" & ThisWorkbook.Worksheets("Data").Rows.Count).End(xlUp).Row 

r = 1 
c = 1 

vDirectory = "G:\QUALITY ASSURANCE\03_AUDITS\PAI\Audit Feedback\Audit Feedback " & Worksheets(1).Range("B9").Value & "\" 

vFile = Dir(vDirectory & "*.doc*") 

Do While vFile <> "" 

Set wdDoc = Documents.Open(filename:=vDirectory & vFile, ReadOnly:=True) 

'Start my loop 

With wdDoc 
TableNo = wdDoc.tables.Count 
    If .tables.Count > 0 Then 
     For i = 1 To TableNo 
      With .tables(i) 
       'copy cell contents from Word table cells to Excel cells 
       For iRow = lastrow To .Rows.Count 
        For iCol = 1 To .Columns.Count 
        On Error Resume Next 
         Worksheets("Data").Cells(r, c) = Trim(WorksheetFunction.Clean(Replace(Replace(.cell(iRow, iCol).Range.Text, Chr(13), " "), Chr(10), ""))) 
         c = c + 1 
        Next iCol 
        c = 1 
        r = r + 1 
       Next iRow 
      End With 
      c = 1 
     Next i 
    End If 
End With 

     wdDoc.Close SaveChanges:=False 
     vFile = Dir 
    Loop 

Application.ScreenUpdating = True 
Application.DisplayAlerts = True 

End Sub