将表格从 Word 复制到 Excel 工作簿

Question

请帮忙！我想从一个有8个表的word文件中复制一个特定的表。我的代码正在运行，但我正在使用索引来检索表。相反，我想使用表中的关键字复制表。假设我如何从 Word 复制表格并仅过滤该表格中的特定信息。例如，在我的代码中，我正在复制表 6，但是如何通过仅过滤 Nbr1 行来从 word 复制同一个表。

这是我的代码：

enter code here


 Option Explicit
    
    
    Private Sub CommandButton2_Click()
        Sheets("Sheet1").Cells.Clear

End Sub

Private Sub CommandButton1_Click()
    copyTableDataFromWord
End Sub

Public Sub copyTableDataFromWord()
    On Error Resume Next
    
    Create a "FileDialog" object as a File Picker dialog box.
    Dim fd As Office.FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    Dim sfileName As String
    
    With fd
        .AllowMultiSelect = False
        .Filters.Clear
        .Title = "Select a Word File"
        .Filters.Add "All Word Documents", "*.doc?", 1
    
        If .Show = True Then
            sfileName = Dir(.SelectedItems(1))      ' Get the file.
        End If
    End With
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    If Trim(sfileName) <> "" Then
        Dim objWord As Object       ' Create a Word object.
        Set objWord = CreateObject("Word.Application")
        objWord.Visible = False      ' Do not show the file.
        
        ' Create a Document object and open the Word file.
        Dim objDoc
        Set objDoc = objWord.Documents.Open(fd.InitialFileName & sfileName)
            
        Dim iTable    ' The table that you want to extract data.
        iTable = 6 ' Set value as 2 or 3 for second or third table (if any).

        ' Note: If you have multiple tables in your word file,
        '  use "objDoc.tables.Count" to get the total tables in the file
        '  and loop through each table.
        
        If objDoc.tables(iTable).Columns.Count > 0 Then     ' Check if it’s a table.
        
            Dim iTotalCols As Integer   ' Get total columns in the table.
            iTotalCols = objDoc.tables(iTable).Columns.Count
            
            Dim iTotalRows As Integer   ' Get total rows in the table.
            iTotalRows = objDoc.tables(iTable).Rows.Count
            
            Dim iRows, iCols As Integer
            Dim txt As Variant
            
            ' Get the table headers first.
            For iCols = 1 To objDoc.tables(iTable).Columns.Count
                txt = objDoc.tables(iTable).cell(1, iCols).Range.Text
                With Sheet1
                    .Cells(1, iCols) = Replace(txt, " ", "")          ' Write the headers in sheet1.
                    .Cells(1, iCols).Font.Bold = True
                End With
            Next iCols
    
            ' Now extract the table data.
            For iRows = 2 To iTotalRows
                For iCols = 1 To iTotalCols
                    txt = objDoc.tables(iTable).cell(iRows, iCols).Range.Text
                    Sheet1.Cells(iRows, iCols) = Replace(txt, " ", "")   ' Show data in sheet1.
                Next iCols
            Next iRows
        End If
        
        ' Add borders to the table.
        Sheet1.UsedRange.Borders.LineStyle = xlContinuous
    End If
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    ' Clean up.
    objWord.Close
    objDoc.Quit
    Set objWord = Nothing
    Set objDoc = Nothing
   End Sub

Answer 1

这是我建议的一个例子：

Public Sub copyTableDataFromWord()
    
    Dim doc As Object, tbl As Object, rw As Object, txt, id
    Dim cDest As Range, app As Object
    
    Set doc = GetWordDoc()
    If doc Is Nothing Then Exit Sub
    
    id = "Nbr1"
    Set cDest = ActiveSheet.Range("A2") 'start copying rows to here
    For Each tbl In doc.tables
        For Each rw In tbl.Rows
            If WordCellText(rw.Cells(1)) = id Then
                RowToRange rw, cDest
                Set cDest = cDest.Offset(1) 'next destination row
            End If
        Next rw
    Next tbl
    Set app = doc.Application
    doc.Close False
    app.Quit 'close word
End Sub
   
'transfer a word table row to Excel range
Sub RowToRange(rw As Object, rng As Range)
    Dim cell As Object, i As Long, txt
    Application.ScreenUpdating = False
    For Each cell In rw.Cells
        rng.Offset(0, i).Value = WordCellText(cell)
        i = i + 1
    Next cell
End Sub

'Return the content of a word table cell, minus the end-of-cell marker
Function WordCellText(cell As Object)
    With cell.Range
        WordCellText = Left(.Text, Len(.Text) - 2) 
    End With
End Function

'get a user-selected Word document
Function GetWordDoc() As Object
    Dim fd As Office.FileDialog
    Dim sfileName As String, objWord As Object, objDoc As Object
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Filters.Clear
        .Title = "Select a Word File"
        .Filters.Add "All Word Documents", "*.doc?", 1
        If .Show = True Then
            sfileName = .SelectedItems(1)      ' Get the file.
            Set objWord = CreateObject("Word.Application")
            objWord.Visible = True     ' Do not show the file.
            Set objDoc = objWord.Documents.Open(sfileName)
            Set GetWordDoc = objDoc
        End If
    End With
End Function