怎样利用VBA将一个文件夹下所有的word文档中的表格数据读取到一个excel中？
在excel中用宏Sub test()Dim i%, ar(1 To 60000, 1 To 20), ttt$, brr()
Dim wordApp As Object, myword As Object, t As Object
Application.ScreenUpdating = False
Set wordApp = CreateObject("Word.Application")
Set myword = wordApp.Documents.Open(ThisWorkbook.Path & "\全省项目排版1014.doc")
wordApp.Visible = 0
On Error Resume Next
ReDim brr(1 To myword.Tables.Count)
For Each t In myword.Tables
If t.Rows.Count < 19 Then
j = 0
ttt = t.Cell(j + 1, 1).Range.Text
Do While InStr(ttt, "名称") = 0
j = j + 1
ttt = t.Cell(j + 1, 1).Range.Text
If j = 5 Then Exit Do
Loop
If j < 4 Then
i = i + 1
ar(i, 1) = t.Cell(1 + j, 2).Range.Text
ar(i, 2) = t.Cell(2 + j, 2).Range.Text
ar(i, 3) = t.Cell(3 + j, 3).Range.Text
ar(i, 4) = t.Cell(3 + j, 5).Range.Text
ar(i, 5) = t.Cell(4 + j, 3).Range.Text
ar(i, 6) = t.Cell(5 + j, 3).Range.Text
ar(i, 7) = t.Cell(6 + j, 3).Range.Text
ar(i, 8) = t.Cell(6 + j, 5).Range.Text
ar(i, 9) = t.Cell(7 + j, 3).Range.Text
ar(i, 10) = t.Cell(8 + j, 3).Range.Text
ar(i, 11) = t.Cell(9 + j, 3).Range.Text
ar(i, 12) = t.Cell(9 + j, 5).Range.Text
ar(i, 13) = t.Cell(10 + j, 3).Range.Text
ar(i, 14) = t.Cell(11 + j, 3).Range.Text
ar(i, 15) = t.Cell(12 + j, 2).Range.Text
ar(i, 16) = t.Cell(13 + j, 2).Range.Text
ar(i, 17) = t.Cell(14 + j, 3).Range.Text
ar(i, 18) = t.Cell(14 + j, 5).Range.Text
ar(i, 19) = t.Cell(15 + j, 3).Range.Text
ar(i, 20) = t.Cell(15 + j, 5).Range.Text
End If
ElseIf t.Rows.Count > 18 Then
For j = 1 To t.Rows.Count Step 18
i = i + 1
ar(i, 1) = t.Cell(1 + 3, 2).Range.Text
ar(i, 2) = t.Cell(2 + 3, 2).Range.Text
ar(i, 3) = t.Cell(3 + 3, 3).Range.Text
ar(i, 4) = t.Cell(3 + 3, 5).Range.Text
ar(i, 5) = t.Cell(4 + 3, 3).Range.Text
ar(i, 6) = t.Cell(5 + 3, 3).Range.Text
ar(i, 7) = t.Cell(6 + 3, 3).Range.Text
ar(i, 8) = t.Cell(6 + 3, 5).Range.Text
ar(i, 9) = t.Cell(7 + 3, 3).Range.Text
ar(i, 10) = t.Cell(8 + 3, 3).Range.Text
ar(i, 11) = t.Cell(9 + 3, 3).Range.Text
ar(i, 12) = t.Cell(9 + 3, 5).Range.Text
ar(i, 13) = t.Cell(10 + 3, 3).Range.Text
ar(i, 14) = t.Cell(11 + 3, 3).Range.Text
ar(i, 15) = t.Cell(12 + 3, 2).Range.Text
ar(i, 16) = t.Cell(13 + 3, 2).Range.Text
ar(i, 17) = t.Cell(14 + 3, 3).Range.Text
ar(i, 18) = t.Cell(14 + 3, 5).Range.Text
ar(i, 19) = t.Cell(15 + 3, 3).Range.Text
ar(i, 20) = t.Cell(15 + 3, 5).Range.Text
Next
End If
Next
myword.Close False
wordApp.Quit
Set wordApp = Nothing
Set myword = Nothing
ActiveSheet.UsedRange.Offset(2).ClearContents
With [a3].Resize(i, 20)
.Value = ar
.Replace Chr(7), "", xlPart
End With
Application.ScreenUpdating = True
End Sub
