为什么排序后行会被删除

Question

我有一个脚本，它可以正确使用 Excel 中的顺序对 Word 中的表格进行排序，但排序后行会被删除。

我用ctrl z一步步查看发生了什么-

1. 行开始从最后一行删除到第 3 行。
2. 删除后，行开始按照我想要的顺序从第 3 行添加。
3. 以正确的顺序添加所有行后，行开始从最后一行到第 3 行被删除。

为什么一旦按照正确的顺序添加行，行就开始被删除。排序完成后不应删除它，意味着添加了行。

有人可以帮我吗？

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

结束子

Answer 1

这是一种更容易管理的不同方法（我认为）：将表内容拉入二维数组，然后根据排序顺序数组将其添加回来。

更容易处理，因为它不会删除任何内容，只会覆盖。 另外（可选）捕获排序顺序列表中未找到的行并将它们添加到最后......

我对排序顺序数组进行了硬编码，以将重点放在实际排序上。

未排序和排序的表：

Sub SortSelectedTablesUsingExcelOrder()

    Dim wdDoc As Document, tbl As Table
    Dim i As Long, data, sortList, currRow As Long, r As Long
    
    Set wdDoc = ActiveDocument
    
    'hard-coding this for testing...
    sortList = Array("Val006", "Val003", "Val002", "Val001", "Val005") 'note no "Val004"
    
    ' Process Word tables
    For Each tbl In wdDoc.Tables
        If UCase(Trim(tbl.Cell(1, 1).Range.Text)) Like "*PARTS REQUIRED*" Then ' Convert table title to uppercase
            data = DataFromTable(tbl, 3) 'get 2D array of table data starting from 3rd row
            currRow = 3
            'Re-populate rows according to the sort list order
            For i = LBound(sortList) To UBound(sortList)
                For r = 1 To UBound(data)
                    If data(r, 1) = sortList(i) Then
                        ArrayToRow tbl, data, currRow, r 'put array "row" to table row
                        currRow = currRow + 1   'next row to fill
                        data(r, 1) = "*added*"  'flag as added
                    End If
                Next r
            Next i
            'Add any remaining rows not matched to the sort list
            For r = 1 To UBound(data)
                If data(r, 1) <> "*added*" Then      'not already copied back
                    ArrayToRow tbl, data, currRow, r 'array "row" to table row
                    currRow = currRow + 1            'next row to fill
                End If
            Next r
        End If 'processing this table
    Next tbl
    
End Sub

'Populate a table row (#rDest) from a specified row `rSrc` in a 2D array `data`
Sub ArrayToRow(tbl As Word.Table, data, rDest As Long, rSrc As Long)
    Dim c As Long
    For c = 1 To UBound(data, 2)
        tbl.Cell(rDest, c).Range.Text = data(rSrc, c)
    Next c
End Sub

'grab the content of a table as a 2-D array, starting at row `rowStart`
Function DataFromTable(tbl As Table, rowStart As Long)
    Dim numCols As Long, numRows As Long, c As Long, r As Long, data, txt
    numRows = tbl.rows.Count
    numCols = tbl.Columns.Count
    ReDim data(1 To numRows - (rowStart - 1), 1 To numCols)
    For r = rowStart To numRows
        For c = 1 To numCols
            txt = tbl.Cell(r, c).Range.Text
            data(r - (rowStart - 1), c) = Left(txt, Len(txt) - 2) 'remove end-of cell marker
        Next c
    Next r
    DataFromTable = data
End Function