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

编辑的问题：

我有一个包含多个word文档的文件夹（docx和doc格式）：

Word Doc 1 Word Doc 2 Word Doc 3 etc. 

目前，我在Excel中有一个VBA代码循环遍历单词文档，并将所有表格数据提取到我的电子表格中。

码：

  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电子表格结果:(每个蓝色突出显示的行是每个word文档中新数据的开始）

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

Answer 1

我设法解决这个问题。 我没有正确定义我的iRowvariables：

 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