VBA 问题将 Word 表中的特定行/列（具有合并的行）复制到 Excel

Question

我有一个带有表格的 Word 文档 (*.docx)

**Name  Description Dimension**

Level   Text 1  Text 11 
        Text 2  Text 12 
        Text 3  Text 13 
        Text 4  Text 14 
        Text 5  Text 15 
        Text 6  Text 16 
test    Text 7  Text 17 

有 3 列和 8 行。

我只想将“名称”列包含“测试”的“描述”列的内容提取到 Excel。

我做了下面的 Excel Marco

    Sub ImportWordTable()

    Dim wdDoc As Object
    Dim wdFileName As Variant
    Dim TableNo As Integer 'table number in Word
    Dim iRow As Long 'row index in Excel
    Dim iCol As Integer 'column index in Excel
    Dim resultRow As Long
    Dim tableStart As Integer
    Dim tableTot As Integer
    Dim nextRow As Integer 'row index in Excel

    On Error Resume Next

    ActiveSheet.Range("A:AZ").ClearContents


    With ActiveSheet.Range("A:AZ")
    ' Create Heading
        HeadingRow = 1

        .Cells(HeadingRow, 1).Formula = "Identifier"

    wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
    "Browse for file containing table to be imported")

    If wdFileName = False Then Exit Sub '(user cancelled import file browser)

    Set wdDoc = GetObject(wdFileName) 'open Word file

    With wdDoc
        TableNo = wdDoc.tables.Count
        tableTot = wdDoc.tables.Count
        If TableNo = 0 Then
            MsgBox "The document contains no tables", _
            vbExclamation, "Import Word Table"
        ElseIf TableNo >= 1 Then
            TableNo = MsgBox("The document contains in TOTAL: " & TableNo & " tables." & vbCrLf)
        End If

        resultRow = 2

        For tableStart = 1 To tableTot
            With .tables(tableStart)
                'copy cell contents from Word table cells to Excel cells


                For iRow = 1 To .Rows.Count
                'determine if the text of the 1th column contains the words "mike"


                    If (.cell(iRow, 1).Range.Text Like "*test*") _
                    Then
                         nextRow = ThisWorkbook.ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row + 1


                    'find the last empty row in the current worksheet
                         nextRow = ThisWorkbook.ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row + 1
                         MsgBox nextRow
                    'copy cell contents from Word table cells to Excel cells

                         For iCol = 1 To 2
                            ThisWorkbook.ActiveSheet.Cells(nextRow, 1) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)

                         Next iCol
                     Else
                        MsgBox "do not containt the word *test*"
                     End If
                Next iRow
            End With
        Next tableStart



End With
End With

End Sub

但结果不是我所期望的。它是：

Identifier
Text 2
Text 3
Text 4
Text 5
Text 6
Text 7

我会期待

Identifier
Text 7

你能帮帮我吗？

看起来这是因为我在 Word 中的行被“合并”了。如果我拆分它们，我会收到我期望的结果，但问题是我有大约 300 个表，所以我无法将它们一一拆分...

谢谢。

Answer 1

你可以试试下面的代码

Sub ImportWordTable()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
On Error Resume Next
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file containing table to be imported")

If wdFileName = False Then Exit Sub '(user cancelled import file browser)
ActiveSheet.Cells(1, 1).Formula = "Identifier"
Set wdDoc = GetObject(wdFileName) 'open Word file
                inRow = 2
                inCol = 1
With wdDoc
   TableNo = wdDoc.tables.Count
   If TableNo = 0 Then
       MsgBox "This document contains no tables", _
       vbExclamation, "Import Word Table"
   ElseIf TableNo > 1 Then
       TableNo = MsgBox("The document contains in TOTAL: " & TableNo & " 
         tables." & vbCrLf) 
   End If
 For tbl = 1 To wdDoc.tables.Count
With .tables(tbl)
    'copy cell contents from Word table cells to Excel cells
    For iRow = 1 To .Rows.Count
        For iCol = 1 To .Columns.Count
            Debug.Print InStr(UCase(WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)), "TEST") & "    " & _
            WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text) & "      " & _
            WorksheetFunction.Clean(.cell(iRow, iCol + 1).Range.Text) & "      " & _
            iRow & "  "; iCol
            com = InStr(UCase(WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)), "TEST")
            If com = 1 Then
                Cells(inRow, inCol) = WorksheetFunction.Clean(.cell(iRow, iCol + 1).Range.Text)
                'Cells(iRow, iCol + 1) = WorksheetFunction.Clean(.cell(iRow, iCol + 2).Range.Text)
                inRow = inRow + 1

            End If
        Next iCol
    Next iRow
End With
Next
End With

Set wdDoc = Nothing

End Sub

Answer 2

只需将下面的 If 条件代码替换为已编辑的版本

If (.cell(iRow, 1).Range.Text Like "*test*") _
            Then

已编辑：

If Instr(UCase(.cell(iRow, 1).Range.Text),Ucase("test")) _
            Then

让我知道它是否有效。谢谢