Excel VBA：すべてのワードドキュメントをループしてテーブルデータを抽出しますか？

Question

質問編集：私は（docxファイルとDOC形式で）複数のワード文書とフォルダを持っている

：私はワード文書や抽出物をループExcelのVBAコードを持っている瞬間

Word Doc 1 
Word Doc 2 
Word Doc 3 
etc. 

私のスプレッドシートにすべてのテーブルデータ。

コード：

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