如何筛选Word表格中的插入型修订并复制至Excel？

我需要处理仅包含表格的Word文档，所有内容都在表格中，部分文档长达数百页且会定期修订。我尝试用Excel VBA打开该文档，只将表格中属于插入修订的行复制到Excel。目前已拼凑出能打开文档并复制所有修订内容到对应列的代码，但不知道如何限定只选择插入类型的修订。

原代码 #

' declare variables
Dim ws As Worksheet
Dim WordFilename As Variant
Dim Filter As String
Dim WordDoc As Object
Dim tbNo As Long
Dim RowOutputNo As Long
Dim RowNo As Long
Dim ColNo As Integer
Dim tbBegin As Integer

Set ws = Worksheets("Analysis")
Filter = "Word File New (*.docx), *.docx," & _
"Word File Old (*.doc), *.doc,"
' clear all of the content in the worksheet where the tables from the Word document are to be imported
ws.Cells.ClearContents
' if you only want to clear a specific range, replace .Cells with the range that you want to clear
' displays a Browser that allows you to select the Word document that contains the table(s) to be imported into Excel
WordFilename = Application.GetOpenFilename(Filter, , "Select Word file")
If WordFilename = False Then Exit Sub
' open the selected Word document
Set WordDoc = GetObject(WordFilename)

With WordDoc

tbNo = WordDoc.Tables.Count

If tbNo = 0 Then
MsgBox "This document contains no tables"
End If

' nominate which row to begin inserting the data from. In this example we are inserting the data from row 1
RowOutputNo = 1

' go through each of the tables in the Word document and insert the data from each of the cells into Excel
For tbBegin = 1 To tbNo
With .Tables(tbBegin)
For RowNo = 1 To .rows.Count
For ColNo = 1 To .Columns.Count

'-----This code works to only select revisions ----------------
'-----Next step - make it only select insertions - 
' OR - let it mark what kind of revision it is-----

            Set rng = .Cell(RowNo, ColNo).Range
            ' don't include the "end of cell" marker in the checked range
            ' rng.MoveEnd wdCharacter, -1
            numRevs = rng.Revisions.Count
                           
            If numRevs > 0 Then

ws.Cells(RowOutputNo, ColNo) = Application.WorksheetFunction.Clean(.Cell(RowNo, ColNo).Range.Text)
End If

Next ColNo
RowOutputNo = RowOutputNo + 1

Next RowNo

End With
RowOutputNo = RowOutputNo

Next tbBegin

End With
End Sub

解决方案 #

要筛选插入类型的修订，核心是利用Word对象模型中Revision.Type属性，插入修订对应的常量为wdRevisionInsert（数值为1，后期绑定场景直接用数值更稳妥）。

修改后的完整代码 #

' declare variables
Dim ws As Worksheet
Dim WordFilename As Variant
Dim Filter As String
Dim WordDoc As Object
Dim tbNo As Long
Dim RowOutputNo As Long
Dim RowNo As Long
Dim ColNo As Integer
Dim tbBegin As Integer
Dim rng As Object ' Word.Range 对象
Dim rev As Object ' Word.Revision 对象
Dim hasInsertRevision As Boolean ' 标记单元格是否包含插入修订

Set ws = Worksheets("Analysis")
Filter = "Word File New (*.docx), *.docx," & _
"Word File Old (*.doc), *.doc,"
' 清空目标工作表内容
ws.Cells.ClearContents

' 选择Word文档
WordFilename = Application.GetOpenFilename(Filter, , "Select Word file")
If WordFilename = False Then Exit Sub

' 打开选中的Word文档
Set WordDoc = GetObject(WordFilename)

With WordDoc
    tbNo = .Tables.Count
    If tbNo = 0 Then
        MsgBox "此文档不包含任何表格"
        Exit Sub
    End If
    
    RowOutputNo = 1 ' Excel中开始插入数据的行号
    
    ' 遍历每个表格
    For tbBegin = 1 To tbNo
        With .Tables(tbBegin)
            ' 遍历表格的每一行
            For RowNo = 1 To .rows.Count
                hasInsertRevision = False
                ' 先检查当前行是否存在插入修订
                For ColNo = 1 To .Columns.Count
                    Set rng = .Cell(RowNo, ColNo).Range
                    rng.MoveEnd wdCharacter, -1 ' 移除单元格末尾标记，避免误判
                    ' 遍历当前单元格的所有修订
                    For Each rev In rng.Revisions
                        ' wdRevisionInsert 对应数值1，判断是否为插入修订
                        If rev.Type = 1 Then
                            hasInsertRevision = True
                            Exit For ' 找到一个插入修订就停止检查当前单元格
                        End If
                    Next rev
                    If hasInsertRevision Then Exit For ' 整行只要有一个插入修订就停止检查列
                Next ColNo
                
                ' 如果当前行存在插入修订，复制整行内容到Excel
                If hasInsertRevision Then
                    For ColNo = 1 To .Columns.Count
                        Set rng = .Cell(RowNo, ColNo).Range
                        rng.MoveEnd wdCharacter, -1
                        ws.Cells(RowOutputNo, ColNo) = Application.WorksheetFunction.Clean(rng.Text)
                    Next ColNo
                    RowOutputNo = RowOutputNo + 1
                End If
            Next RowNo
        End With
    Next tbBegin
End With

' 释放对象
Set WordDoc = Nothing
Set rng = Nothing
Set rev = Nothing

关键修改说明 #

1. 新增变量：添加rng（Word单元格范围）、rev（单个修订对象）、hasInsertRevision（标记是否存在插入修订）。
2. 修订类型判断：遍历单元格内的所有修订，通过rev.Type = 1判断是否为插入修订（wdRevisionInsert的数值）。
3. 整行筛选逻辑：先检查整行是否存在插入修订，确认后再复制整行内容到Excel，避免只复制单个有修订的单元格。
4. 优化单元格范围：启用rng.MoveEnd wdCharacter, -1移除单元格末尾的隐藏标记，避免修订判断出错。
5. 对象释放：添加对象释放代码，避免内存泄漏。

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