Блог

Это сложный вопрос, и я не смог даже попытаться использовать код VBA, чтобы попытаться разобраться в этом. Использование таблицы.Сортировка не помогает. Вот пример ниже, если вас смущает то, что мне требуется:

 BEFORE            AFTER
rice              rice
pea               rice
apple             pea
vegetable         pea
vegetable         apple
pea               apple
apple             vegetable
rice              vegetable
orange            orange
 

Как вы можете видеть выше, хотя данные во втором столбце отсортированы упорядоченным образом, они не в алфавитном порядке. Возможно ли это сделать без необходимости размещать цифры перед текстом в столбце таблицы, а затем сортировать? Или мне не нужно делать все это вручную? Мой приведенный выше пример является простым, и для больших объемов информации было бы непрактично делать это вручную. Я могу делать то, что мне нужно в EXCEL, используя формулы, но мне действительно нужны возможности обработки текста WORD, а не EXCEL.

Для работы этого кода вам нужна эта ссылка.
Это выполняется из Word VBA, а не из Excel.

 Sub SortingSortOf()
Dim XL As Excel.Application, WB As Excel.Workbook
Dim WS As Excel.Worksheet, MatchCol As Excel.Range, Tbl As Table

    Set XL = Excel.Application
    Set WB = XL.Workbooks.Open("C:PathToWorkbookWithYourTable.xlsm") ' or.xlsx
    Set WS = WB.Sheets("NameOfTableSheet")
    
    ' places a sort value one column to the right of the current data
    Set MatchCol = WS.UsedRange.Columns(WS.Cells.SpecialCells(xlCellTypeLastCell).Column   1)
    
    ' change this to whatever column holds your sort value
    MatchCol.Formula = "=Match(A1, A:A, 0)"
    
    ' i'm assuming you have some sort of header
    WS.UsedRange.Sort Key1:=MatchCol, Header:=xlYes
    
    'optional, unless you want the sort number displayed in the table
    MatchCol.Delete
    
    ' or wherever you want. doesn't have to be paragraph 1
    If ActiveDocument.Paragraphs(1).Range.Tables.Count > 0 Then
        ' for some reason it doesn't overwrite an existing table
        ' so this will delete it first (even if there is more than one)
        For Each Tbl In ActiveDocument.Paragraphs(1).Range.Tables
            Tbl.Delete
        Next Tbl
    End If
    WS.UsedRange.Copy
    ActiveDocument.Paragraphs(1).Range.Paste
    
    ' putting false on close should prevent the save changes dialog,
    ' but there seems to be an excel bug, so shutting off alerts
    XL.DisplayAlerts = False
    WB.Close , False
    XL.DisplayAlerts = True
End Sub
 

У меня было немного свободного времени, поэтому я создал программу для сортировки таблицы в Word на основе моего понимания ваших правил сортировки.

 Sub Example()
    Call CustomSort(ThisDocument.Tables(1))
End Sub

Sub CustomSort(sortTable As Table)
    'Create an array that contains the table values
    Dim Items() As String
    ReDim Items(1 To sortTable.Rows.Count, 1 To sortTable.Columns.Count)
    
    Dim i As Long, j As Long
    For i = 1 To sortTable.Rows.Count
        For j = 1 To sortTable.Columns.Count
            Items(i, j) = Left(sortTable.Cell(i, j).Range.Text, Len(sortTable.Cell(i, j).Range.Text) - 2) 
            'removes the extra characters at the end of a cell - credit to Timothy Rylatt
        Next j
    Next i

    'Sort the table
    Dim r As Long
    For i = 1 To UBound(Items, 1) - 2
        For r = i   2 To UBound(Items, 1)
            If Items(i, 1) = Items(r, 1) Then Call ArrayRowShift(Items, r, i   1)
        Next r
    Next i
    
    'Output the table
    For i = 1 To sortTable.Rows.Count
        For j = 1 To sortTable.Columns.Count
            sortTable.Cell(i, j).Range.Text = Items(i, j)
        Next j
    Next i
End Sub
Sub ArrayRowShift(ByRef Arr As Variant, RowIndex As Long, MoveTo As Long)
    'For 2D arrays, takes an array row, moves it to the specified index, returns the shifted array
    If RowIndex = MoveTo Then Exit Sub
    Dim tmpRow() As Variant
    ReDim tmpRow(LBound(Arr, 2) To UBound(Arr, 2))
    For j = LBound(Arr, 2) To UBound(Arr, 2)
        tmpRow(j) = Arr(RowIndex, j)
    Next j
    If RowIndex < MoveTo Then
        For i = RowIndex   1 To MoveTo
            For j = LBound(Arr, 2) To UBound(Arr, 2)
                Arr(i - 1, j) = Arr(i, j)
            Next j
        Next i
    Else
        For i = RowIndex To MoveTo   1 Step -1
            For j = LBound(Arr, 2) To UBound(Arr, 2)
                Arr(i, j) = Arr(i - 1, j)
            Next j
        Next i
    End If
    For j = LBound(Arr, 2) To UBound(Arr, 2)
        Arr(MoveTo, j) = tmpRow(j)
    Next j
End Sub
 

Я беру текст таблицы в массив, переупорядочиваю элементы в массиве с помощью VBA, затем вставляю его обратно в таблицу. Это работает для любого размера таблицы в Word (1D или 2D).

Если вы хотите настроить правила сортировки, вам нужно отредактировать строку If Items(i, 1) = Items(r, 1) Then . Возможно, вы захотите добавить LCase оба, чтобы убрать чувствительность к регистру. Или Trim , чтобы убедиться, что лишний пробел не мешает совпадениям.