Problem mit VBA Copy bestimmten Zeile/Spalte aus Word-Tabelle (mit fusionierten Zeilen) nach Excel

Question

Ich habe ein Word-Dokument (* .docx) mit einem Tisch

**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 

mit 3 Spalten und 8 Reihen.

Ich möchte in Excel nur den Inhalt der Spalte "Beschreibung" extrahieren, für die die Spalte "Name" "Test" enthält.

Ich habe folgendes 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 

aber das Ergebnis ist nicht das, was ich erwartet hatte. Es ist:

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

Und ich würde erwarten,

Identifier 
Text 7 

Könnten Sie mir bitte helfen?

Es sieht wie das aus, dass meine Zeilen in Word "zusammengeführt" werden. Wenn ich sie teile, erhalte ich, was ich erwarte, aber das Problem ist, dass ich ungefähr 300 Tabellen habe, also kann ich sie nicht einzeln teilen ...

Danke.

Answer 1

können Sie versuchen, den Code unten

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

Ersetzen Sie einfach den Ist die Bedingung Code aus dem unten auf die bearbeitete Version

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

Edited:

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

Lassen Sie mich wissen, ob es funktioniert.

Dank