Option Explicit
Option Private Module
'====================================================================================================
Sub ADO()
Dim ADO_RS As New ADODB.Recordset, ADO_C As New ADODB.Connection
Dim arr, aOut(), q$, q2$, t!, r&, c&

t = Timer
    q = "[" & shData.Name & "$A:D]"
    q = "SELECT DISTINCT * FROM " & q & "ORDER BY F1,F2 DESC ,F3,F4 DESC"
    q2 = "Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=NO"";"
    ADO_C.Open q2: ADO_RS.Open q, ADO_C
    arr = ADO_RS.GetRows
Debug.Print "Main", Format$(1000 * (Timer - t), "0 ms")                 ' 0.54 sec

t = Timer
    ReDim aOut(1 To UBound(arr, 2) + 1, 1 To UBound(arr, 1) + 1)
    For r = 1 To UBound(aOut, 1)
        For c = 1 To UBound(aOut, 2)
            aOut(r, c) = arr(c - 1, r - 1)
        Next c
    Next r
Debug.Print "Trns", Format$(1000 * (Timer - t), "0 ms")                 ' 0.01 sec (12 ms)

t = Timer
    ArrOut aOut                                                         ' 0.14 sec / 30 817 rows
Debug.Print "Out", Format$(1000 * (Timer - t), "0 ms"), Format$(UBound(aOut, 1), "#,##0 el")
End Sub

Option Explicit
Option Private Module
'====================================================================================================
'====================================================================================================
Sub TestSort_1Recur()
Dim aAll, aOut(), aVal(), aInd() As Long
Dim t1!, t2!, t3!, tt!, r&, c&

ArrGet aAll

t1 = Timer
ReDim aVal(1 To UBound(aAll, 1)): ReDim aInd(1 To UBound(aVal))
    For r = 1 To UBound(aAll, 1)
        aVal(r) = aAll(r, 1): aInd(r) = r
    Next r
t1 = Timer - t1                                                 ' 63 ms

t2 = Timer
    Sort1dRecurWithInd aVal, aInd, 1, UBound(aInd)
t2 = Timer - t2                                                 ' 1 172 ms

t3 = Timer
    ReDim aOut(1 To UBound(aAll, 1), 1 To UBound(aAll, 2))
    For r = 1 To UBound(aInd)
        For c = 1 To UBound(aAll, 2)
            aOut(r, c) = aAll(aInd(r), c)
        Next c
    Next r
t3 = Timer - t3                                                 ' 344 ms. Total: 1.58 sec

Debug.Print "Prepare", Format$(1000 * t1, "0 ms")
Debug.Print "Sort", Format$(1000 * t2, "0 ms")
Debug.Print "ReBuild", Format$(1000 * t3, "0 ms")
Debug.Print "Total", Format$((t1 + t2 + t3), "0.00 sec")
ArrOut aOut
End Sub
'====================================================================================================
'====================================================================================================
Sub TestSort_1Sheet()
Dim t!

t = Timer
    shData.Copy after:=ActiveSheet
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A1:A500000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

        .SetRange Range("A1:D500000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Debug.Print "Sort", Format$(Timer - t, "0.00 sec")              ' 2.1 sec
End Sub
'----------------------------------------------------------------------------------------------------
Sub TestSort_4Sheet()
Dim t!

t = Timer
    shData.Copy after:=ActiveSheet
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A1:A500000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("B1:B500000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("C1:C500000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("D1:D500000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    
        .SetRange Range("A1:D500000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Debug.Print "Sort", Format$(Timer - t, "0.00 sec")              ' 2.8 sec
End Sub
'====================================================================================================
'====================================================================================================
Sub TestSort_1Bedvit()
Dim aAll, t!

ArrGet aAll
t = Timer
    BV.ArraySortV aAll
Debug.Print "bedvit", Format$(1000 * (Timer - t), "0 ms") ' 200 ms
ArrOut aAll
End Sub

Option Explicit
Option Private Module
'====================================================================================================
Sub UniqDic()
Dim dic As New Dictionary
Dim x, aAll, aOut()
Dim tx$, t!, r&, rr&, c&, cc&

ArrGet (aAll): t = Timer
rr = UBound(aAll, 1): cc = UBound(aAll, 2)
For r = 1 To rr
    tx = aAll(r, 1)
    For c = 2 To cc
        tx = tx & aAll(r, c)
    Next c
    If Not dic.Exists(tx) Then dic.Add tx, r
Next r


ReDim aOut(1 To dic.Count, 1 To cc): r = 0
For Each x In dic.Items
    r = r + 1
    For c = 1 To cc
        aOut(r, c) = aAll(x, c)
    Next c
Next x

Debug.Print Timer - t, "UniqDic", UBound(aOut, 1)                       ' 2.02 sec / 61 719 rows
ArrOut aOut
End Sub
'====================================================================================================
'====================================================================================================
Sub UniqBedvit()
Dim map As New BedvitCOM.UnorderedMap
Dim x, aAll, aOut(), aRows() As Long
Dim tx$, t!, r&, rr&, c&, cc&, u&

ArrGet aAll: t = Timer
rr = UBound(aAll, 1): cc = UBound(aAll, 2)
ReDim aRows(1 To rr)

For r = 1 To rr
    tx = aAll(r, 1)
    For c = 2 To cc
        tx = tx & aAll(r, c)
    Next c
    If map.Insert(tx, 0) Then u = u + 1: aRows(u) = r
Next r

ReDim aOut(1 To u, 1 To cc)

For r = 1 To u
    For c = 1 To cc
        aOut(r, c) = aAll(aRows(r), c)
    Next c
Next r

Debug.Print Timer - t, "UniqBedvit", u                                  ' 1.63 sec / 61 719 rows
ArrOut aOut
End Sub
'====================================================================================================
Sub UniqBedvitTranspose()
Dim map As New BedvitCOM.UnorderedMap
Dim x, aAll, aOut
Dim tx$, t!, r&, rr&, c&, cc&, u&

ArrGet aAll: t = Timer
rr = UBound(aAll, 1): cc = UBound(aAll, 2)
ReDim aOut(1 To cc, 1 To rr)    ' Array-reverse for ReDim Preserve

For r = 1 To rr
    tx = aAll(r, 1)
    For c = 2 To cc
        tx = tx & aAll(r, c)
    Next c

    If map.Insert(tx, 0) Then
        u = u + 1
        For c = 1 To cc
            aOut(c, u) = aAll(r, c)
        Next c
    End If
Next r

ReDim Preserve aOut(1 To cc, 1 To u)
BV.Transpose aOut

Debug.Print Timer - t, "UniqBedvit", u                                  ' 1.69 sec / 61 719 rows
ArrOut aOut
End Sub

Option Explicit
Option Private Module
'====================================================================================================
Public BV As New BedvitCOM.VBA  ' https://bedvit.ru/xll/
'====================================================================================================
Sub ArrGet(arr)
    arr = shData.Range("A1:D500000").Value2
End Sub
'====================================================================================================
Sub ArrOut(arr, Optional iRows&, Optional iColumns&)
    If iRows = 0 Then iRows = UBound(arr, 1) - LBound(arr, 1) + 1
    If iColumns = 0 Then iColumns = UBound(arr, 2) - LBound(arr, 2) + 1

    Worksheets.Add after:=ActiveSheet
    Cells(1, 1).Resize(iRows, iColumns).Value2 = arr
End Sub
'====================================================================================================
Sub Sort1dRecurWithInd(arrVal(), arrInd() As Long, l&, u&)
Dim x, y, n&, i&, j&

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

        Do
            Do While arrVal(i) < x: i = i + 1: Loop
            Do While x < arrVal(j): j = j - 1: Loop
            If i <= j Then
                y = arrVal(i): arrVal(i) = arrVal(j): arrVal(j) = y
                n = arrInd(i): arrInd(i) = arrInd(j): arrInd(j) = n
                i = i + 1: j = j - 1
            End If
        Loop Until i > j

If l < j Then Sort1dRecurWithInd arrVal, arrInd, l, j
If i < u Then Sort1dRecurWithInd arrVal, arrInd, i, u
End Sub

Option Explicit
Option Private Module
'====================================================================================================
Public BV As New BedvitCOM.VBA  ' https://bedvit.ru/xll/
'====================================================================================================
Sub UniqDic()
Dim dic As New Dictionary
Dim x, aAll, aOut()
Dim tx$, t!, r&, rr&, c&, cc&

aAll = shData.Range("A1:D500000").Value2
t = Timer


rr = UBound(aAll, 1): cc = UBound(aAll, 2)

For r = 1 To rr
    tx = aAll(r, 1)
    For c = 2 To cc
        tx = tx & aAll(r, c)
    Next c
    If Not dic.Exists(tx) Then dic.Add tx, r
Next r


ReDim aOut(1 To dic.Count, 1 To cc): r = 0

For Each x In dic.Items
    r = r + 1
    For c = 1 To cc
        aOut(r, c) = aAll(x, c)
    Next c
Next x


Debug.Print Timer - t, "UniqDic", UBound(aOut, 1)   ' 2.02 sec / 61 719 rows

Worksheets.Add After:=ActiveSheet
Cells(1, 1).Resize(UBound(aOut, 1), cc).Value2 = aOut
End Sub
'====================================================================================================
'====================================================================================================
Sub UniqBedvit()
Dim map As New BedvitCOM.UnorderedMap
Dim x, aAll, aOut(), aRows() As Long
Dim tx$, t!, r&, rr&, c&, cc&, u&

aAll = shData.Range("A1:D500000").Value2
t = Timer

rr = UBound(aAll, 1): cc = UBound(aAll, 2)
ReDim aRows(1 To rr)

For r = 1 To rr
    tx = aAll(r, 1)
    For c = 2 To cc
        tx = tx & aAll(r, c)
    Next c
    If map.Insert(tx, 0) Then u = u + 1: aRows(u) = r
Next r

ReDim aOut(1 To u, 1 To cc)

For r = 1 To u
    For c = 1 To cc
        aOut(r, c) = aAll(aRows(r), c)
    Next c
Next r


Debug.Print Timer - t, "UniqBedvit", u   ' 1.63 sec / 61 719 rows

Worksheets.Add After:=ActiveSheet
Cells(1, 1).Resize(u, cc).Value2 = aOut
End Sub
'====================================================================================================
Sub UniqBedvitTranspose()
Dim map As New BedvitCOM.UnorderedMap
Dim x, aAll, aOut
Dim tx$, t!, r&, rr&, c&, cc&, u&

aAll = shData.Range("A1:D500000").Value2
t = Timer

rr = UBound(aAll, 1): cc = UBound(aAll, 2)
ReDim aOut(1 To cc, 1 To rr)    ' Array-reverse for ReDim Preserve

For r = 1 To rr
    tx = aAll(r, 1)
    For c = 2 To cc
        tx = tx & aAll(r, c)
    Next c

    If map.Insert(tx, 0) Then
        u = u + 1
        For c = 1 To cc
            aOut(c, u) = aAll(r, c)
        Next c
    End If
Next r

ReDim Preserve aOut(1 To cc, 1 To u)
BV.Transpose aOut

Debug.Print Timer - t, "UniqBedvit", u   ' 1.69 sec / 61 719 rows

Worksheets.Add After:=ActiveSheet
Cells(1, 1).Resize(u, cc).Value2 = aOut
End Sub
'====================================================================================================