请编码帮助

Question

我正在尝试打开一个包含 3 个表格的 MS Word 文档，我想将这些数据提取到 MS Excel 中。 我花了时间查看 VBA 代码，它帮助我完成了这项工作。 当我运行下面的代码时，它会提示我 select 这个 word 文件，我想将数据提取到 Excel。

当下面的代码完成后，它将打开带有名称表 1 的新 excel 工作簿，带有两个选项卡“表 2”和“表 3”，每次运行代码时它都会有新的工作簿名称。（表 2、表 3 和很快）

我想将那些新创建的两个选项卡“表 2”和“表 3”复制到我正在工作但似乎无法正常工作的主数据文件的选项卡中。 总而言之，我想将通过运行以下代码创建的两个选项卡“工作表 2”和“工作表 3”复制到主工作簿名称“主文件”的“粘贴”选项卡。

Sub CopyTables()
    Dim oWord As Word.Application
    Dim WordNotOpen As Boolean
    Dim oDoc As Word.Document
    Dim oTbl As Word.table
    Dim fd As Office.FileDialog
    Dim FilePath As String
    Dim wbk As Workbook
    Dim base As Workbook
    Dim wsh As Worksheet
    
    Set base = ActiveWorkbook
    
    ' Prompt for document
    Set fd = Application.FileDialog(msoFileDialogOpen)
    With fd
        .Filters.Clear
        .Filters.Add "Word Documents (*.docx)", "*.docx", 1
        .Title = "Choose a Word File"
        If .Show = True Then
            FilePath = .SelectedItems(1)
        Else
            Beep
            Exit Sub
        End If
    End With
   
    On Error Resume Next
   
    Application.ScreenUpdating = False
   
    ' Create new workbook
    Set wbk = Workbooks.Add(Template:=xlWBATWorksheet)
   
    ' Get or start Word
    Set oWord = GetObject(Class:="Word.Application")
    If Err Then
        Set oWord = New Word.Application
        WordNotOpen = True
    End If
   
    On Error GoTo Err_Handler
   
    ' Open document
    Set oDoc = oWord.Documents.Open(Filename:=FilePath)
    ' Loop through the tables
    For Each oTbl In oDoc.Tables
        ' Create new sheet
        Set wsh = wbk.Worksheets.Add(After:=wbk.Worksheets(wbk.Worksheets.Count))
        ' Copy/paste the table
        oTbl.Range.Copy
        wsh.Paste

    Next oTbl
 
   
    ' Delete the first sheet
    Application.DisplayAlerts = False
    wbk.Worksheets(1).Delete
    Application.DisplayAlerts = True
   
Exit_Handler:
    On Error Resume Next
    oDoc.Close SaveChanges:=False
    If WordNotOpen Then
        oWord.Quit
    End If
    'Release object references
    Set oTbl = Nothing
    Set oDoc = Nothing
    Set oWord = Nothing
    Application.ScreenUpdating = True
    Exit Sub
   
Err_Handler:
    MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
    Resume Exit_Handler
End Sub