Алгоритм сортировки данных 900000 строк данных

Вам предстоит решить 3 задачи:

а) У вас огромный объем данных, поэтому вам нужна быстрая процедура.
Это просто: считайте все данные в память за один раз (в двумерный массив). Работайте над этим массивом. Когда все будет отсортировано, запишите данные обратно в Excel за один раз.

Sub sortMydata()
    With Worksheets("Tabelle1")
        Dim rowcount As Long
        rowcount = .Range("AA1").CurrentRegion.Rows.Count
        ' Read Excel data into 2-dimensional array
        Dim data
        data = .Range("AA1").Resize(rowcount, 4)
        ' Sort all rows
        For row = 2 To rowcount
            sortrow data, row
        Next
        ' Write sorted data back into sheet    
        .Range("AA1").Resize(rowcount, 4) = data
    End With
End Sub

б) Вам необходимо отсортировать данные (строка за строкой). Для этого нам нужен алгоритм сортировки. Поскольку мы всегда сортируем лишь очень небольшое количество значений (по 4 в строке), лучшим вариантом является простая пузырьковая сортировка. В Интернете можно найти множество реализаций. Единственное, что нам нужно знать, это то, что мы хотим сортировать значения одной строки, тогда как большинство алгоритмов предполагают, что вы хотите сортировать данные по одному (или нескольким) столбцам.

Sub sortrow(data, row As Long)
    Dim i As Long, j As Long
    ' A simple Bubble Sort to sort the values of one Row
    For i = LBound(data, 2) To UBound(data, 2) - 1
        For j = i To UBound(data, 2)
            If sortBefore(data(row, j), data(row, i)) Then
                Dim tmp As Variant
                tmp = data(row, i)
                data(row, i) = data(row, j)
                data(row, j) = tmp
            End If
        Next
    Next
End Sub

в) Вам нужен алгоритм, который сравнивает два значения, чтобы решить, какое из них будет «первым». Алгоритм сортировки будет использовать это для сортировки ваших данных.

Function sortBefore(v1 As Variant, v2 As Variant) As Boolean
    If v1 = "" Then
        sortBefore = False            ' Blanks to the end
    ElseIf IsNumeric(v1) Then
        If IsNumeric(v2) Then
            sortBefore = v1 > v2      ' Compare Numeric values: Larger first
        Else
            sortBefore = True         ' Number before string
        End If
    Else
        If IsNumeric(v2) Then
            sortBefore = False        ' String after numeric
        Else
            sortBefore = LCase(v1) < LCase(v2)      ' Compare string values: Smaller first
        End If
    End If
End Function

Запуск программы со 100 000 строк данных занял 1–2 секунды.

Другим подходом может быть использование Power Query, также этот подход должен быстро работать с большими данными.

Код для использования:

let
    Source = Excel.CurrentWorkbook(){[Name = "Table1"]}[Content],
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(Source, {"Column AA"}, "column name", "Value"),
    #"Removed Columns" = Table.RemoveColumns(#"Unpivoted Other Columns",{"column name"}),
    #"Added Custom" = Table.AddColumn(#"Removed Columns", "sort rank", each try Text.Length(Number.ToText([Value])) otherwise 0),
    #"Grouped Rows" = Table.Group(#"Added Custom", {"Column AA"}, {{"row", each _}}),
    sorted = Table.TransformColumns(#"Grouped Rows", {"row", each Table.Sort(_, {"sort rank", Order.Descending})}),
    index_added = Table.TransformColumns(sorted, {"row", each Table.AddIndexColumn(_, "index")}),
    #"Expanded row" = Table.ExpandTableColumn(index_added, "row", {"Value", "index"}, {"Value", "index"}),
    #"Pivoted Column" = Table.Pivot(Table.TransformColumnTypes(#"Expanded row", {{"index", type text}}, "en-GB"), List.Distinct(Table.TransformColumnTypes(#"Expanded row", {{"index", type text}}, "en-GB")[index]), "index", "Value")
in
    #"Pivoted Column"

Вывод: (слева: отсортировано, справа: оригинал)

Я использовал ArrayList, но не уверен, что это применимо к вам.

Option Explicit

Sub SortIt()
    Dim list As Object, listA As Object
    Set list = CreateObject("System.Collections.ArrayList")
    Set listA = CreateObject("System.Collections.ArrayList")

    'Set list = New ArrayList
    'Set listA = New ArrayList

    Dim v As Variant
    Dim i As Long
    Dim sngRow As Range
    Dim wks As Worksheet
    Set wks = ActiveSheet
    
    For Each sngRow In wks.Range("A1:D10").Rows
        v = sngRow.Value
        For i = LBound(v, 2) To UBound(v, 2)
            If Len(v(1, i)) > 0 Then
                If IsNumeric(v(1, i)) Then
                    list.Add v(1, i)
                Else
                    listA.Add v(1, i)
                End If
            End If
        Next
        list.Sort
        list.Reverse
        Debug.Print list.Count, listA.Count
    
        ' write to sheet to the right in column 6
        
        v = list.toarray
        With wks
            .Range(.Cells(sngRow.Row, 6), .Cells(sngRow.Row, 6 + list.Count - 1)) = v
            v = listA.toarray
            .Range(.Cells(sngRow.Row, 6 + list.Count), .Cells(sngRow.Row, 6 + list.Count + listA.Count - 1)) = v
        End With
        list.Clear
        listA.Clear
    Next sngRow
End Sub

Поскольку обращений к рабочим листам все еще много, это, вероятно, не так быстро. Но это можно исправить, и можно продолжать использовать подход со списком массивов.

Изменил его таким образом, чтобы количество обращений к листу было сведено к минимуму.

Option Explicit

Sub sortMemory()
    Dim list As Object, listA As Object
    Set list = CreateObject("System.Collections.ArrayList")
    Set listA = CreateObject("System.Collections.ArrayList")

    'Set list = New ArrayList
    'Set listA = New ArrayList

    Dim v As Variant
    Dim vDat As Variant
    Dim i As Long, j As Long, k As Long, listCount As Long
    
    Dim wks As Worksheet
    Set wks = ActiveSheet
        
    ' Data in Region of A1
    vDat = wks.Range("A1").CurrentRegion.Value
    
    For j = LBound(vDat, 1) To UBound(vDat, 1)
        For i = LBound(vDat, 2) To UBound(vDat, 2)
            If Len(vDat(j, i)) > 0 Then
                If IsNumeric(vDat(j, i)) Then
                    list.Add vDat(j, i)
                Else
                    listA.Add vDat(j, i)
                End If
            End If
        Next
        list.Sort
        list.Reverse
            
        ' Change array
        v = list.toarray
        For k = LBound(v) To UBound(v)
            vDat(j, k + 1) = v(k)
        Next k
        
        v = listA.toarray
        listCount = list.Count
        
        For k = 1 + listCount To UBound(vDat, 2)
            vDat(j, k) = ""
        Next
        If UBound(v) >= 0 Then
            For k = LBound(v) To UBound(v)
                vDat(j, k + 1 + listCount) = v(k)
            Next k
        End If
        
        list.Clear
        listA.Clear
    Next
    
    ' Output starting in Column 6, adjust accordingly
    With wks
        .Range(.Cells(1, 6), .Cells(UBound(vDat, 1), 6 + UBound(vDat, 2) - 1)) = vDat
    End With

End Sub