VBA问题将特定行/列从Word表格（合并行）复制到Excel

我有一个带表格的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行的

我只想将“Description”列的内容提取到Excel中，“Name”列包含“test”

我做了以下的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张桌子，所以我不能把它们一张一张地分开

---

谢谢。

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

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

编辑：

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

---

让我知道它是否有效。谢谢你能试试下面的代码吗

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

---

在为行添加“.”（点）后是否可以尝试：If（.cell（iRow，1）.Range.Text Like“.test”）\u它不起作用。。。标识符文本2文本3文本4文本5文本6您能否具体说明，您得到了什么标识符文本2文本3文本4文本5文本6使用Instr函数，如果Instr（.cell（iRow，1）.Range.Text，“test”）很抱歉，但可能无法工作，因为我在“Level”列中合并了线，而不是正确的网格线。欢迎。谢谢