VB宏实现Word需求表格导入Excel的问题排查与解决

需求 #

遍历Word文档，提取每个Heading1样式标题下包含“Requirement”的表格，将Heading1文本作为表格每行的第一列导入Excel。

问题历程 #

初始问题 #

• Word中显示为Heading1样式的文本，无法通过代码获取内容；
• Word自动生成的格式化编号无法复制到Excel单元格；
• 导出到Excel的单元格存在类似vbCrLf的特殊字符，显示为长矩形。

2024/5/23 更新 #

通过转换为ASCII码发现特殊字符为Chr(13)，将其替换为vbCrLf并移除末尾vbCr，同时设置WrapText=True后，特殊字符问题已解决。但仍存在两个问题：

1. Range.Text无法识别Word自动生成的编号值，使用Range.ListFormat.ListString也无法获取该值；
2. 代码中的行/列计数逻辑可能存在问题。

参考代码 #

代码1：CopyAllRequirementTablesToExcel #

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
    
    ' 创建Excel实例（若未运行则新建）
    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
    
    ' 引用新建工作簿和工作表
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Sheets(1)
    
    ' 初始化Excel起始行
    row = 1
    
    ' 遍历Word文档中所有表格
    For Each tbl In ActiveDocument.Tables
        found = False
        hasVerticallyMergedCells = False
        foundHeading1 = False
        
        ' 设置表格所在段落索引
        paraIndex = tbl.Range.Paragraphs.Count
        
        ' 反向查找最近的Heading1样式段落
        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
        
        ' 未找到Heading1时设置默认文本
        If Not foundHeading1 Then
            headingText = "No Heading 1 found"
        End If
        
        ' 调试输出Heading1文本
        Debug.Print "Heading 1 Text: " & headingText
        
        ' 检查表格是否包含"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 found Then
            If tbl.Columns.Count > 1 Then
                For i = 2 To tbl.Rows.Count ' 跳过表头行
                    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
            
            ' 无垂直合并单元格则导入Excel
            If Not hasVerticallyMergedCells Then
                ' 写入Heading1文本作为第一列
                xlSheet.Cells(row, 1).Value = headingText
                
                ' 复制表格内容到Excel（跳过表头行）
                For i = 2 To tbl.Rows.Count
                    For j = 1 To tbl.Columns.Count
                        xlSheet.Cells(row + i - 2, j).Value = Trim(tbl.cell(i, j).Range.Text)
                    Next j
                Next i
                
                ' 更新Excel起始行
                row = row + tbl.Rows.Count - 1
            End If
        End If
    Next tbl
    
    ' 显示Excel窗口
    xlApp.Visible = True
    
    ' 释放对象
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    
    ' 未找到目标表格时提示（已注释）
    'If Not found Then
        'MsgBox "No table with 'Requirement' heading found.", vbInformation
    'End If
End Sub 

代码2：CopySDDFromWordToExcel #

Option Explicit
Sub CopySDDFromWordToExcel()
    Dim oTab As Table, colHead As New Collection, sHead As String
    Dim i As Long, r As Range
    Dim row As Integer
    Dim column As Integer
    Dim x As Integer
    Dim y As Integer
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object

    ' 创建Excel实例（若未运行则新建）
    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
    
    row = 1
    column = 1
    
    ' 引用新建工作簿和工作表并显示Excel
    xlApp.Visible = True
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Sheets(1)
    
    Set r = ActiveDocument.Content
    ' 查找所有Heading1样式段落并加入集合
    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
        ' 设置当前Heading1的内容范围
        If i = colHead.Count Then
            colHead(i).End = ThisDocument.Range.End
        Else
            colHead(i).End = colHead(i + 1).Start - 1
        End If
        ' 遍历当前Heading1下的表格
        If colHead(i).Tables.Count > 0 Then
            Debug.Print "-----"
            Debug.Print sHead
            Debug.Print "-- Table: ", i, "---"
            
            For Each oTab In colHead(i).Tables
                With oTab.Range.Find
                    .ClearFormatting
                    .text = "Requirement"
                    If .Execute Then
                        Debug.Print "-----"
                        Debug.Print "Found table"
                        Debug.Print "Start: "; .Parent.Start
                        Debug.Print "End: "; .Parent.End
                        
                        ' 复制表格内容到Excel（跳过表头行）
                        For x = 2 To oTab.Rows.Count
                            For y = 1 To oTab.Columns.Count
                                ' 写入Heading1文本作为第一列
                                If y = 1 Then
                                    xlSheet.Cells(row + x - 2, y).Value = sHead
                                End If
                                ' 尝试写入自动编号到第二列
                                If y = 2 Then
                                    xlSheet.Cells(row + x - 2, y + 1).Value = oTab.cell(x, y).Range.ListFormat.ListString
                                End If
                                ' 处理剩余单元格并替换特殊字符
                                If y > 2 Then
                                    xlSheet.Cells(row + x - 2, y + 1).Value = Replace(RemoveLastCarriageReturn(Trim(oTab.cell(x, y).Range.text)), Chr(13), vbCrLf)
                                    xlSheet.Cells(row + x - 2, y + 1).WrapText = True
                                End If
                            Next y
                            row = row + 1
                        Next x
                    End If
                End With
            Next
        End If
    Next

    ' 释放对象
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing

End Sub

Function RemoveLastCarriageReturn(ByVal inputString As String) As String
    Dim lastCRPosition As Integer
    lastCRPosition = InStrRev(inputString, vbCr)
    
    If lastCRPosition > 0 Then
        RemoveLastCarriageReturn = Left(inputString, lastCRPosition - 1)
    Else
        RemoveLastCarriageReturn = inputString
    End If
End Function

Function ConverToASCII(inputString As String) As String
    Dim asciiValues As String
    Dim i As Integer
    
    asciiValues = ""
    ' 遍历字符输出ASCII值
    For i = 1 To Len(inputString)
        asciiValues = asciiValues & Asc(Mid(inputString, i, 1)) & " "
    Next i
    
    Debug.Print "The ASCII values of '" & inputString & "' are: " & asciiValues
End Function

内容的提问来源于stack exchange，提问作者Mrbobdou