Option Explicit
'===========================================================================================
Const rMax& = 100000
'===========================================================================================
Sub sort()
Dim arrBefore, arrAfter() As String, str$, r&, t!
Dim bVBA As New BedvitCOM.VBA

t = Timer
Randomize
ReDim arrBefore(1 To rMax, 1 To 1) As String
    For r = 1 To rMax
        arrBefore(r, 1) = Rnd
    Next r
arrAfter = arrBefore
Debug.Print Timer - t

t = Timer
bVBA.ArraySort (arrAfter)
Debug.Print Timer - t

t = Timer
shTest.Cells(1, 1).Resize(rMax, 1).Value2 = arrBefore
shTest.Cells(1, 2).Resize(rMax, 1).Value2 = arrAfter
Debug.Print Timer - t

'MsgBox "Время работы: " & Format$(Timer - t, "0.00 сек"), vbInformation, "ГОТОВО"
End Sub

Option Explicit
Option Private Module
'===========================================================================================
'Const rMax& = 100000                    ' задаём количество элементов одномерного массива
'Const iType As Byte = 2                 ' задаём тип одномерного массива для создания: 0 - числа, 1 - текст, 2 - смешано
'Const TestRecursive As Boolean = 0      ' задаём тип сортировки (True - для рекурсии, False - для сортировки от bedvid'а)
'===========================================================================================
Dim arrBefore, arrAfter(), arrReport(4), txtReport$
Dim nElem&, rError&, nType As Byte
'===========================================================================================
Sub Start()
Dim t!

If [num].Value2 = "100k" Then nElem = 100000 Else nElem = 1000000
nType = WorksheetFunction.Match([Type].Value2, [Search], 0)
If [sort].Value2 = "bedvit" Then txtReport = "SortBedvit" Else txtReport = "SortRecursive"
Application.ScreenUpdating = False
' 1 ===============================
t = Timer
With shTest.Cells(1, 1).Resize(1000000, 2): .ClearContents: .Interior.Color = xlNone: End With
arrReport(0) = "SheetClear: " & Format$(1000 * (Timer - t), "0 ms")

' 2 ===============================
t = Timer
ArrayCreate
arrReport(1) = "ArrayCreate: " & Format$(1000 * (Timer - t), "0 ms") & vbLf & String$(20, "-")

' 3 ===============================
    If txtReport = "SortBedvit" Then
        t = Timer
        SortBedvit
    Else
        t = Timer
        arrAfter = arrBefore
        SortRecursive arrAfter, 0, nElem - 1
    End If
arrReport(2) = txtReport & ": " & Format$(1000 * (Timer - t), "0 ms") & vbLf & String$(20, "-")

' 4 ===============================
t = Timer
ArraysInsert
arrReport(3) = "ArraysInsert: " & Format$(1000 * (Timer - t), "0 ms")

' 5 ===============================
t = Timer
ArrayCheck
arrReport(4) = "ArraysInsert: " & Format$(1000 * (Timer - t), "0 ms")

' Msg =============================
Application.ScreenUpdating = True
txtReport = txtReport & vbLf & vbLf & Join(arrReport, vbLf) & vbLf & vbLf

    If rError Then
        MsgBox txtReport & "Ошибка на строке №" & rError, vbCritical, "ArrayCheck"
        shTest.Cells(rError, 2).Interior.Color = vbRed: shTest.Cells(rError, 2).Select
    Else
        MsgBox txtReport & "Ошибок не выявлено", vbInformation, "ArrayCheck"
    End If

'===========================================================================================
Erase arrBefore: Erase arrAfter: Erase arrReport
txtReport$ = ""
nElem = 0: nType = 0: rError = 0
End Sub
'===========================================================================================
Sub SortRecursive(arr1x(), l&, u&)
Dim i&, j&, x, y

i = l: j = u: x = arr1x((l + u) \ 2)

        Do
            Do While arr1x(i) < x: i = i + 1: Loop
            Do While x < arr1x(j): j = j - 1: Loop
            If i <= j Then y = arr1x(i): arr1x(i) = arr1x(j): arr1x(j) = y: i = i + 1: j = j - 1
        Loop Until i > j

If l < j Then Call SortRecursive(arr1x, l, j)
If i < u Then Call SortRecursive(arr1x, i, u)
End Sub
'===========================================================================================
Sub SortBedvit()
Dim arrString, i&
Dim bVBA As Object

ReDim arrString(UBound(arrBefore)) As String

    For i = 0 To UBound(arrBefore)
        arrString(i) = arrBefore(i)
    Next i

With CreateObject("BedvitCOM.VBA"): .ArraySort arrString: End With
ReDim arrAfter(UBound(arrString))

    For i = 0 To UBound(arrString)
        If IsNumeric(arrString(i)) Then arrAfter(i) = --arrString(i) Else arrAfter(i) = arrString(i)
    Next i

End Sub
'===========================================================================================
'===========================================================================================
'===========================================================================================
Sub ArrayCheck()
Dim i&

    For i = 0 To UBound(arrAfter) - 1
        If arrAfter(i) > arrAfter(i + 1) Then rError = i + 1: Exit Sub
    Next i

rError = 0
End Sub
'===========================================================================================
Sub ArrayCreate()
Dim i&

ReDim arrBefore(nElem - 1)
Randomize

    If nType = 1 Then
        For i = 0 To UBound(arrBefore)
            arrBefore(i) = Rnd
        Next i

    ElseIf nType = 2 Then
        For i = 0 To UBound(arrBefore)
            arrBefore(i) = 1000000000 * Rnd
        Next i

    ElseIf nType = 3 Then
        For i = 0 To UBound(arrBefore)
            arrBefore(i) = --Format$(1000000000 * Rnd, "0")
        Next i

    ElseIf nType = 4 Then
        For i = 0 To UBound(arrBefore)
            arrBefore(i) = "_" & Format$(1000000000 * Rnd, "0000000000")
        Next i

    ElseIf nType = 5 Then
        For i = 0 To UBound(arrBefore)
            If i Mod 2 Then
                arrBefore(i) = --Format$(1000000000 * Rnd, "0000000000")
            Else
                arrBefore(i) = "_" & Format$(1000000000 * Rnd, "0000000000")
            End If
        Next i
    End If
End Sub
'===========================================================================================
Sub ArraysInsert()
Dim arr2x(), r&

ReDim arr2x(1 To nElem, 1 To 2)

    For r = 1 To UBound(arr2x, 1)
        arr2x(r, 1) = arrBefore(r - 1)
        arr2x(r, 2) = arrAfter(r - 1)
    Next r

shTest.Cells(1, 1).Resize(UBound(arr2x, 1), UBound(arr2x, 2)).Value2 = arr2x
End Sub
'===========================================================================================

Function ArrayCreate(nType as Byte, nElem&) As Variant()
Dim arr(),i&
 
ReDim arr(nElem - 1)
Randomize

' Числа
    If nType = 1 Then
        For i = 0 To UBound(arr)
            arr(i) = Rnd
        Next i

 ' Числа
    ElseIf nType = 2 Then
        For i = 0 To UBound(arr)
            arr(i) = 1000000000 * Rnd
        Next i

  ' Числа
    ElseIf nType = 3 Then
        For i = 0 To UBound(arr)
            arr(i) = --Format$(1000000000 * Rnd, "0")
        Next i

  ' Текст
    ElseIf nType = 4 Then
        For i = 0 To UBound(arr)
            arr(i) = "_" & Format$(1000000000 * Rnd, "0000000000")
        Next i

  ' Числа + Текст
    ElseIf nType = 5 Then
        For i = 0 To UBound(arr)
            If i Mod 2 Then
                arr(i) = --Format$(1000000000 * Rnd, "0000000000")
            Else
                arr(i) = "_" & Format$(1000000000 * Rnd, "0000000000")
            End If
        Next i
    End If
ArrayCreate=arr
End Function

Sub ArrayCheck()
Dim i&
    For i = 0 To UBound(arrAfter) - 1
        If arrAfter(i) > arrAfter(i + 1) Then rError = i + 1: Exit Sub
    Next i
rError = 0
End Sub

Option Explicit'===========================================================================================
Sub Test()
Dim arr, s$, i&, t1!, t2!
Const rMax& = 1000000

t1 = Timer
s = String(1000, "x")
ReDim arr(rMax - 1)

    For i = LBound(arr) To UBound(arr)
        arr(i) = s
    Next i
Debug.Print Format$(Timer - t1, "0.000")

' SlowMo
t1 = Timer
    For i = LBound(arr) To UBound(arr)
        Dummy (arr(i))
    Next i
t1 = Timer - t1

' Fast
t2 = Timer
Fast arr
t2 = Timer - t2

Debug.Print Format$(1000 * (t1 - t2), "0 ms") & " : " & Format$(t1 / t2, "0.00 freq")
End Sub
'===========================================================================================
Sub Fast(arr)
Dim i&
    For i = LBound(arr) To UBound(arr)
        arr(i) = "_" & arr(i)
    Next i
End Sub
'===========================================================================================
Sub Dummy(txt$)
txt = "_" & txt
End Sub
'===========================================================================================

Имя события проблемы:   APPCRASH
Имя приложения:   EXCEL.EXE
Версия приложения:   16.0.10325.20082
Отметка времени приложения:   5b525820
Имя модуля с ошибкой:   ntdll.dll
Версия модуля с ошибкой:   6.1.7601.18247
Отметка времени модуля с ошибкой:   521eaf24
Код исключения:   c0000005
Смещение исключения:   00000000000532f2
Версия ОС:   6.1.7601.2.1.0.768.2
Код языка:   1049

Дополнительные сведения об этой проблеме:
LCID:   1049
skulcid:   1049