Библиотека COM (OLE Automation). Часть 1 - ArraySort (String)

Sub Test_arr_sort()
'Dim bVBA As BedvitCOM.VBA: Set a = New BedvitCOM.VBA 'ранее связывание
Dim bVBA As Object: Set bVBA = CreateObject("BedvitCOM.VBA") 'позднее связывание
Dim testSize As Long: testSize = 2000000
Dim arr_index, arrTmp, i As Long, J As Long, t
 
''''''''''''1х массив'''''''''''''''''''''''
Dim Arr1: ReDim Arr1(-5 To testSize) As String
Dim Arr2: ReDim Arr2(-5 To testSize, -2 To 3) As String
 
'arr(5) - NULL - проверка для сортировки пустых
Arr1(6) = 0
Arr1(7) = "Test_arr_sort"
For i = 8 To testSize
  Arr1(i) = Format$(Int(Rnd * testSize), "0000000") '30% дубликатов
Next
 
arrTmp = Arr1 '!
t = Timer
bVBA.ArraySortS arrTmp
Debug.Print "Простая сорт. 1х массива, по возрастанию (по умолч.): " & Timer - t & " сек."
 
arrTmp = Arr1 '!!
t = Timer
bVBA.ArraySortS arrTmp, 1, , , , , 1, 0, 0
Debug.Print "Простая сорт.по убыванию 1x массива с удалением" & ((UBound(arrTmp) - LBound(arrTmp)) / (testSize - LBound(arrTmp)) - 1) * 100 & "%: " & Timer - t & " сек."
 
'arrTmp = arr - начальный массив не меняется, поэтому темповый - не нужен '!
t = Timer
bVBA.ArraySortS Arr1, 1, , , , , , 1, arr_index
Debug.Print "Вывод индексов для 1х массива, сортировка по убыванию:" & Timer - t & " сек."
 
''''''''''''2х массив'''''''''''''''''''''''
'arr(5) - NULL - проверка для сортировки пустых
Arr2(6, 2) = 0
Arr2(7, 2) = "Test_arr_sort"
For i = 8 To testSize
    For J = -2 To 3
        Arr2(i, J) = Format$(Int(Rnd * testSize), "0000000") '30% дубликатов
    Next
Next
 
arrTmp = Arr2 '!
t = Timer
bVBA.ArraySortS arrTmp, 0, , , , 2, 0, 0, 0
Debug.Print "Сортировка всего 2х массива - вывод строка-столбец: " & Timer - t & " сек."
 
arrTmp = Arr2 '!
t = Timer
bVBA.ArraySortS arrTmp, 0, 5, , , 3, 0, 0, 0
Debug.Print "Сортировка всего 2х массива - вывод столбец-строка " & Timer - t & " сек."
 
arrTmp = Arr2 '!
t = Timer
bVBA.ArraySortS arrTmp
Debug.Print "Простая сортировка 2х массива: " & Timer - t & " сек."
 
arrTmp = Arr2 '!
t = Timer '!
bVBA.ArraySortS arrTmp, 0, 3, , , , , 1, arr_index
Debug.Print "Вывод индексов для 2х массива, по указанному столбцу: " & Timer - t & " сек."
 
arrTmp = Arr2 '!
t = Timer
bVBA.ArraySortS arrTmp, 0, 5, , , 1, 0, 0, 0
Debug.Print "Сортировка 2х массива по 5му столбцу: " & Timer - t & " сек."
 
arrTmp = Arr2 '!
t = Timer '!
bVBA.ArraySortS arrTmp, 0, 8, , , 1, , 1, arr_index
Debug.Print "Вывод индексов для 2х массива, по 8й строке: " & Timer - t & " сек."
 
arrTmp = Arr2 '!
t = Timer
bVBA.ArraySortS arrTmp, 0, 8, , , 1, 0, 0, 0
Debug.Print "Сортировка 2х массива по 8й строке: " & Timer - t & " сек."
 
arrTmp = Arr2 '!
t = Timer
bVBA.ArraySortS arrTmp, 0, 1, 2, 3, 0, , 1, arr_index
Debug.Print "Вывод индексов для 2х массива, по 1,2,3му столбцу: " & Timer - t & " сек."
 
arrTmp = Arr2 '!
t = Timer
bVBA.ArraySortS arrTmp, 0, 1, 2, 3, 0, 0, 0, 0
Debug.Print "Сортировка 2х массива по 1,2,3му столбцу: " & Timer - t & " сек."
 
arrTmp = Arr2 '!
t = Timer
bVBA.ArraySortS arrTmp, 0, 8, 9, 10, 1, 0, 1, arr_index
Debug.Print "Вывод индексов для 8,9,10й строке: " & Timer - t & " сек."
 
arrTmp = Arr2 '!
t = Timer
bVBA.ArraySortS arrTmp, 0, 8, 9, 10, 1, 0, 0, 0
Debug.Print "Сортировка 2х массива по 8,9,10й строке: " & Timer - t & " сек."
 
Set bVBA = Nothing
End Sub

Option Explicit
Const testSize = 2000000
Dim a(testSize), x$, y$
 
Sub test()
Dim i&
For i = 0 To testSize
  a(i) = Format$(Int(Rnd * testSize), "0000000")
Next
 
Dim t#
t = Timer
QuickSort 0, testSize
Debug.Print Timer - t
 
End Sub
 
Sub QuickSort(ByVal L As Long, ByVal U As Long)
Dim i As Long, j As Long
i = L: j = U: x = a((L + U) \ 2)
Do
  While a(i) < x: i = i + 1: Wend: While x < a(j): j = j - 1: Wend 'по возрастанию
'  While A(I) > X: I = I + 1: Wend: While X > A(J): J = J - 1: Wend 'по убыванию
  If i <= j Then
    y = a(i): a(i) = a(j): a(j) = y:    i = i + 1: j = j - 1
  End If
Loop Until i > j
If L < j Then QuickSort L, j
If i < U Then QuickSort i, U
End Sub