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中提取“名称”列包含“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张桌子所以我不能一个一个地分开它们......

谢谢。

Answer 1

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

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

编辑：

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

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

Answer 2

您可以尝试以下代码

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

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

2 个答案: