使用Excel排序Word表格后行被删除的原因及排查方案

问题现象 #

我编写的VBA脚本原本要根据Excel指定的顺序对Word中的表格排序，但执行后表格行被删除。通过Ctrl+Z回溯操作过程，发现：

• 第一步：从最后一行到第3行删除行
• 第二步：从第3行开始按预期顺序添加行
• 第三步：所有行添加完成后，再次从最后一行到第3行删除行

排序完成后不应出现第二次删除操作，请问问题出在哪里？下一步该怎么处理？

相关VBA代码 #

Sub SortSelectedTablesUsingExcelOrder()

    Dim wdDoc As Document
    Dim wdTable As table
    Dim excelApp As Object
    Dim excelWorkbook As Object
    Dim excelSheet As Object
    Dim sortOrder() As String
    Dim i As Long, j As Long
    Dim cellValue As String
    Dim rowIndex As Long
    Dim newRow As row
    Dim colCount As Long
    Dim fileDialog As fileDialog
    Dim filePath As String
    Dim lastRow As Long
    Dim matchedRows As Collection
    Dim rowText As Variant
    Dim tableCellValue As String

    Set wdDoc = ActiveDocument

    ' File selection dialog for Excel file
    Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
    With fileDialog
        .Title = "Select the Excel File"
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm", 1
        .AllowMultiSelect = False
        If .Show = -1 Then
            filePath = .SelectedItems(1)
        Else
            MsgBox "No file selected. Exiting.", vbExclamation
            Exit Sub
        End If
    End With

    ' Initialize Excel application
    Set excelApp = CreateObject("Excel.Application")
    excelApp.Visible = False
    Set excelWorkbook = excelApp.Workbooks.Open(filePath)
    Set excelSheet = excelWorkbook.Sheets(2)

    lastRow = excelSheet.Cells(excelSheet.Rows.Count, 1).End(-4162).row

    ' Load Excel order into sortOrder array
    ReDim sortOrder(1 To lastRow)
    For i = 1 To lastRow
        sortOrder(i) = UCase(excelSheet.Cells(i, 1).Value) ' Convert to uppercase
        Debug.Print "Excel Order " & i & ": " & sortOrder(i) ' Print Excel order in Immediate Window
    Next i

    ' Process Word tables
    For Each wdTable In wdDoc.Tables
        If UCase(Trim(wdTable.cell(1, 1).Range.Text)) Like "*PARTS REQUIRED*" Then ' Convert table title to uppercase
            colCount = wdTable.Columns.Count
            Set matchedRows = New Collection

            ' Gather matched rows from the Word table
            For i = 1 To lastRow
                cellValue = sortOrder(i)
                Debug.Print "Processing Excel Value: " & cellValue ' Print currently processing Excel value

                For rowIndex = 3 To wdTable.Rows.Count
                    tableCellValue = UCase(Left(wdTable.cell(rowIndex, 1).Range.Text, Len(wdTable.cell(rowIndex, 1).Range.Text) - 2)) ' Convert to uppercase

                    If tableCellValue = cellValue Then
                        rowText = ""

                        ' Collect the data from the matched row
                        For j = 1 To colCount
                            rowText = rowText & wdTable.cell(rowIndex, j).Range.Text & vbTab
                        Next j
                        rowText = Left(rowText, Len(rowText) - 1)
                        matchedRows.Add rowText

                        ' Print matched row
                        Debug.Print "Matched Row " & rowIndex & ": " & rowText
                    End If
                Next rowIndex
            Next i

            ' Now, clear the table and add the rows back in the correct order
            For rowIndex = wdTable.Rows.Count To 3 Step -1
                wdTable.Rows(rowIndex).Delete
            Next rowIndex

            ' Insert rows back based on the matched order
            For Each rowText In matchedRows
                Set newRow = wdTable.Rows.Add

                Dim rowData() As String
                rowData = Split(rowText, vbTab)

                For j = 1 To colCount
                    newRow.Cells(j).Range.Text = rowData(j - 1)
                Next j

                ' Print new row data after insertion
                Debug.Print "Inserted Row: " & Join(rowData, vbTab)
            Next rowText
        End If
    Next wdTable

    ' Clean up the Word table content
    For Each wdTable In wdDoc.Tables
        tableTitle = UCase(Trim(wdTable.cell(1, 1).Range.Text)) ' Convert title to uppercase
        tableTitle = Left(tableTitle, Len(tableTitle) - 2)

        If tableTitle = "PARTS REQUIRED" Then
            For Each tableCell In wdTable.Range.Cells
                tableCell.Range.Text = Replace(tableCell.Range.Text, vbCr, "")
            Next tableCell
        End If
    Next wdTable

    ' Close Excel
    excelWorkbook.Close SaveChanges:=False
    excelApp.Quit
    Set excelApp = Nothing
    Set excelWorkbook = Nothing
    Set excelSheet = Nothing
    Set wdDoc = Nothing

End Sub

问题根源分析 #

核心问题出在**For Each wdTable In wdDoc.Tables循环中修改表格结构**：
当你在循环内给表格添加新行时，Word的Tables集合会被动态修改，导致For Each枚举出现异常——可能会重复遍历同一个目标表格，从而再次执行删除行的代码（For rowIndex = wdTable.Rows.Count To 3 Step -1），把刚添加的行删掉。

解决方案 #

将第一个遍历表格的循环改为索引倒序遍历，避免集合修改导致的重复处理：

' 替换原来的"Process Word tables"循环部分
Dim tableIndex As Long
For tableIndex = wdDoc.Tables.Count To 1 Step -1
    Set wdTable = wdDoc.Tables(tableIndex)
    If UCase(Trim(wdTable.cell(1, 1).Range.Text)) Like "*PARTS REQUIRED*" Then
        ' 原来的收集行、删除旧行、添加新行的逻辑保持不变
    End If
Next tableIndex

下一步排查方向 #

1. 先修改循环遍历方式，验证是否解决重复删除问题
2. 在删除行和添加行的代码前后，添加Debug.Print "当前表格行数: " & wdTable.Rows.Count，监控行数变化
3. 检查matchedRows集合的内容，确认没有重复或空行数据（可在添加后打印集合大小：Debug.Print "匹配到的行数: " & matchedRows.Count）
4. 确保tableTitle变量在第二个循环中被正确声明（添加Dim tableTitle As String，避免变量污染）

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