主页 / user-28457996

VKK's questions

Martin Hope
VKK
Asked: 2024-12-06 05:11:34 +0800 CST
  • 5

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

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

  1. 从最后一行到第三行开始被删除。
  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

End Sub
vba