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

我有一个Word文档（*的.docx）和具有3列8行的表问题与Word表格VBA复制特定的行/列（含合并行）到Excel

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

。

我想提取到Excel仅列“名称”包含“测试”列的“说明”的内容。

我做了以下的Excel马尔科

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张桌子，所以我无法一个一个地分割它们...

谢谢。

来源

2017-07-21 Lilly

你能加入后再试“” （点）：If（.cell（iRow，1）.Range.Text Like“* .test。*”）_ –

它不工作...标识符文本2 文本3 文本4 文本5 文本6 – Lilly

CAn你是具体的，你在做什么 –

你可以试试下面的代码

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

来源

2017-07-21 19:41:41

这一个工程。万分感谢。 – Lilly

欢迎。谢谢 –

刚刚从下面的更换。如果条件代码编辑后的版本

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

编辑：

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

让我知道它的工作。由于

来源

2017-07-21 13:49:47

对不起，但没有工作，可能是因为我已经合并线和“级”列中没有适当的网格线。 – Lilly

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

回答

相关问题