It’s been years since I’ve done VB and I’m having trouble figuring out why I’m not capturing the correct content.

I want to loop through a Word document and parse out all the tables that hold requirements, so they can be tracked in Excel.

I have a Header 1 style, followed by paragraphs and tables.

For each Header 1 style found, I want to copy the text within the Heading 1, as well as any tables with the word “Requirement” in it. The Heading 1 text should be the first column for each row in the table.

The current issues I’m having:

• Although Word shows the text is a “Heading 1” – no matter what I try, I’m not able to grab the text for that item.
• Since I’m using the auto generated formatted numbering within Word, none of the text/content for the cell comes over.
• Every cell that is outputted into Excel, has what looks like a vbCrLf, which displays in Excel as a special character that looks like a tall rectangle.

I included some screenshots for reference.

Word

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