Sub 提取表格()
Dim wdapp As Object, wdoc As Object
fpath = ThisWorkbook.Path
fname = Sheets(1).Cells(1, 2)
pctpath = Sheets(1).Cells(2, 2)
rowstart = Sheets(1).Range("A10000").End(xlUp).Row
item1 = Sheets(1).Cells(6, 1)
yesno = Dir(fpath & "\" & fname & ".doc*")
If yesno <> "" Then
Set wdapp = CreateObject("Word.Application")
wdapp.Visible = True
Set wdDoc = wdapp.Documents.Open(fpath & "\" & yesno)
tcount = wdDoc.Tables.Count
For i = 1 To tcount
r = 0
With wdDoc.Tables(i)
On Error Resume Next
For j = 1 To .Rows.Count
For k = 1 To .Columns.Count
y = Application.WorksheetFunction.clean(Replace(.cell(j, k).Range.Text, "", ""))
Debug.Print y, .Columns.Count, k
Sheets(1).Cells(rowstart + i, r + k) = Application.WorksheetFunction.clean(Replace(.cell(j, k).Range.Text, "", ""))
Next
r = r + .Columns.Count
Next
End With
Next
End If
wdDoc.Close
wdapp.Quit
Set wdTable = Nothing
Set wdDoc = Nothing
Set wdapp = Nothing
MsgBox "完成!"
End Sub