将表格数据从Word复制到Excel

Question

自从我完成 VB 以来已经很多年了，但我无法弄清楚为什么我没有捕获正确的内容。

我想循环遍历 Word 文档并解析出包含需求的所有表格，以便可以在 Excel 中跟踪它们。

我有一个标题 1 样式，后面是段落和表格。

对于找到的每个标题 1 样式，我想复制标题 1 中的文本以及其中包含“要求”一词的任何表格。标题 1 文本应该是表中每行的第一列。

我目前遇到的问题：

• 虽然 Word 显示文本是“标题 1” - 无论我如何尝试，我都无法获取该项目的文本。
• 由于我在 Word 中使用自动生成的格式化编号，因此单元格的任何文本/内容都不会出现。
• 输出到 Excel 中的每个单元格都有一个看起来像 vbCrLf 的内容，它在 Excel 中显示为一个看起来像高矩形的特殊字符。

我提供了一些屏幕截图以供参考。

词

Excel

Sub CopyAllRequirementTablesToExcel()
    Dim tbl As Table
    Dim cell As cell
    Dim found As Boolean
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim i As Integer
    Dim j As Integer
    Dim row As Integer
    Dim hasVerticallyMergedCells As Boolean
    Dim startRow As Integer
    Dim endRow As Integer
    Dim headingText As String
    Dim rng As Range
    Dim para As Paragraph
    Dim foundHeading1 As Boolean
    Dim paraIndex As Integer
    
    ' Create a new instance of Excel if not already running
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    
    ' Reference the first workbook and sheet
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Sheets(1)
    
    ' Initialize the row to start pasting in Excel
    row = 1
    
    ' Loop through each table in the Word document
    For Each tbl In ActiveDocument.Tables
        found = False
        hasVerticallyMergedCells = False
        foundHeading1 = False
        
        ' Set the index of the paragraph containing the table
        paraIndex = tbl.Range.Paragraphs.Count
        
        ' Loop backward through paragraphs until we find the first instance of the next Heading 1 style
        Do Until foundHeading1 Or paraIndex = 1
            If tbl.Range.Paragraphs(paraIndex).Style = "Heading 1" Then
                headingText = Trim(tbl.Range.Paragraphs(paraIndex).Range.Text)
                foundHeading1 = True
            Else
                paraIndex = paraIndex - 1
            End If
        Loop
        
        ' If a Heading 1 style is not found, set headingText to an empty string
        If Not foundHeading1 Then
            headingText = "No Heading 1 found"
        End If
        
        ' Debugging: Print out the Heading 1 text
        Debug.Print "Heading 1 Text: " & headingText
        
        ' Check if any cell in the table contains "Requirement"
        For Each cell In tbl.Range.Cells
            If InStr(1, cell.Range.Text, "Requirement", vbTextCompare) > 0 Then
                found = True
                Exit For
            End If
        Next cell
        
        ' If "Requirement" is found in the table, check for vertically merged cells
        If found Then
            If tbl.Columns.Count > 1 Then ' Check if the table has more than one column
                For i = 2 To tbl.Rows.Count ' Skip the first row
                    For j = 1 To tbl.Columns.Count
                        startRow = tbl.cell(i, j).Range.Information(wdStartOfRangeRowNumber)
                        endRow = tbl.cell(i, j).Range.Information(wdEndOfRangeRowNumber)
                        If startRow <> endRow Then
                            hasVerticallyMergedCells = True
                            Exit For
                        End If
                    Next j
                    If hasVerticallyMergedCells Then Exit For
                Next i
            End If
            
            ' Skip the table if it has vertically merged cells
            If Not hasVerticallyMergedCells Then
                ' Insert the heading text as the first column
                xlSheet.Cells(row, 1).Value = headingText
                
                ' Copy the table to Excel, starting from the second column and second row
                For i = 2 To tbl.Rows.Count ' Skip the first row
                    For j = 1 To tbl.Columns.Count
                        ' Set the value of the cell in Excel to the formatted text of the cell in Word
                        xlSheet.Cells(row + i - 2, j).Value = Trim(tbl.cell(i, j).Range.Text)
                    Next j
                Next i
                
                ' Update the row to the next empty row
                row = row + tbl.Rows.Count - 1 ' Subtract 1 to remove the empty row between tables
            End If
        End If
    Next tbl
    
    ' Make Excel visible
    xlApp.Visible = True
    
    ' Clean up
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    
    ' Notify if no table with 'Requirement' heading is found
    'If Not found Then
        'MsgBox "No table with 'Requirement' heading found.", vbInformation
    'End If
End Sub 

Answer 1

• 下面的代码展示了如何使用

  Find

  方法来定位

  Heading 1

  样式并检查

  requirement

  是否在表格中。
• 它比循环遍历文档中的段落和表格中的单元格更有效。

Option Explicit
Sub demo()
    Dim oTab As Table, colHead As New Collection, sHead As String
    Dim i As Long, r As Range
    Set r = ActiveDocument.Content
    With r.Find
        .ClearFormatting
        .Style = wdStyleHeading1
        .Forward = True
        .Wrap = wdFindStop
        Do While .Execute
            colHead.Add .Parent.Duplicate
            r.Collapse Direction:=wdCollapseEnd
        Loop
    End With
    If colHead.Count = 0 Then
        MsgBox "Can't find Heading 1"
        Exit Sub
    End If
    For i = 1 To colHead.Count
        sHead = colHead(i).Text
        If i = colHead.Count Then
            colHead(i).End = ThisDocument.Range.End
        Else
            colHead(i).End = colHead(i + 1).Start - 1
        End If
        If colHead(i).Tables.Count > 0 Then
            Debug.Print "-----"
            Debug.Print sHead
            For Each oTab In colHead(i).Tables
                With oTab.Range.Find
                    .ClearFormatting
                    .Text = "requirement"
                    .MatchCase = False
                    If .Execute Then
                        Debug.Print "Found table"
                        Debug.Print "Start: "; .Parent.Start
                        Debug.Print "End: "; .Parent.End
                    End If
                End With
            Next
        End If
    Next
End Sub

输出：

-----
Heading 1 Text1

Found table
Start:  66 
End:  77 
-----
Heading 1 Text3

Found table
Start:  209 
End:  220 

样本文档：