VBA 一键提取Word中表格内容

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