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!, tt!, r&, rr&, c&, cc&, u&

t = Timer
    ArrGet aAll: rr = UBound(aAll, 1): cc = UBound(aAll, 2)
t = Timer - t: Debug.Print t, "Prepare"                 ' 0.11

t = Timer
    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
t = Timer - t: tt = tt + t: Debug.Print t, "GetUniq"    ' 1.59

t = Timer
    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
t = Timer - t: tt = tt + t: Debug.Print t, "reBuild"    ' 0.03

t = Timer
    ArrOut aOut
t = Timer - t: Debug.Print t, "Out"                     ' 0.26

Debug.Print tt, "Main", Format$(u, "#,##0")             ' 1.63 / 61 719
End Sub
'====================================================================================================
Sub UniqBedvitTranspose()
Dim map As New BedvitCOM.UnorderedMap
Dim x, aAll, aOut
Dim tx$, t!, tt!, r&, rr&, c&, cc&, u&

t = Timer
    ArrGet aAll
    rr = UBound(aAll, 1): cc = UBound(aAll, 2)
t = Timer - t: Debug.Print t, "Prepare"                         ' 0.01

t = Timer
    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
t = Timer - t: tt = tt + t: Debug.Print t, "1. reBuild"         ' 1.64

t = Timer
    ReDim Preserve aOut(1 To cc, 1 To u)
t = Timer - t: tt = tt + t: Debug.Print t, "2. ReDim Preserve"  ' 0.05

t = Timer
    BV.Transpose aOut
t = Timer - t: tt = tt + t: Debug.Print t, "3. Transpose"       ' 0.01

t = Timer
    ArrOut aOut
t = Timer - t: Debug.Print t, "Out"                             ' 0.29

Debug.Print tt, "Main", Format$(u, "#,##0")                     ' 1.69 / 61 719
End Sub

Option Explicit
Option Private Module
'====================================================================================================
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
'====================================================================================================
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_4Bedvit()
Dim aAll, t!

ArrGet aAll
t = Timer
    BV.ArraySortV aAll, 1, , 2, 1, 3, , "4,1"
Debug.Print "bedvit", Format$(1000 * (Timer - t), "0 ms")       ' 688 ms
ArrOut aAll
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

Option Explicit
Option Private Module
'====================================================================================================
Sub TestAll_BedvitDicSort()
Dim map As New BedvitCOM.UnorderedMap
Dim aAll, aOut, aRows() As Long
Dim tx$, t!, tt!, r&, rr&, c&, cc&, u&

t = Timer
    ArrGet aAll: rr = UBound(aAll, 1): cc = UBound(aAll, 2)
t = Timer - t: Debug.Print t, "Prepare"                     ' 0.08

t = Timer
    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
t = Timer - t: tt = tt + t: Debug.Print t, "1. GetUniq"     ' 1.61

t = Timer
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
t = Timer - t: tt = tt + t: Debug.Print t, "2. reBuild"     ' 0.03

t = Timer
    BV.ArraySortV aOut, 1, 0, 2, 1, 3, 0, "4,1"
t = Timer - t: tt = tt + t: Debug.Print t, "3. Sort"        ' 0.06

t = Timer
    ArrOut aOut
t = Timer - t: Debug.Print t, "Out", Format$(u, "#,##0")    ' 0.28 / 61 719

Debug.Print tt, "Main Time"                                 ' 1.71
End Sub
'====================================================================================================
Sub TestAll_BedvitSortOnly()
Dim x, aAll, aOut, f As Boolean
Dim tx$, t!, tt!, r&, rr&, c&, cc&, u&

t = Timer
    ArrGet aAll: rr = UBound(aAll, 1): cc = UBound(aAll, 2)
t = Timer - t: Debug.Print t, "Prepare"                     ' 0.09

t = Timer
    BV.ArraySortV aAll, 1, 0, 2, 1, 3, 0, "4,1"
t = Timer - t: tt = tt + t: Debug.Print t, "1. Sort"        ' 0.67

t = Timer
    ReDim aOut(1 To cc, 1 To rr)    ' reverse array
    For c = 1 To cc                 ' fill 1st row (reverse col)
        aOut(c, 1) = aAll(1, c)
    Next c

    u = 1                          ' counter for new rows
    For r = 2 To rr
        For c = 1 To cc
            If aAll(r, c) <> aAll(r - 1, c) Then f = True: Exit For
        Next c

        If f Then
            f = False: u = u + 1
            For c = 1 To cc
                aOut(c, u) = aAll(r, c)
            Next c
        End If
    Next r
t = Timer - t: tt = tt + t: Debug.Print t, "2. reBuild"     ' 0.31

t = Timer
    BV.Transpose aOut
t = Timer - t: tt = tt + t: Debug.Print t, "3. Transpose"   ' 0.04

t = Timer
    ArrOut aOut
t = Timer - t: Debug.Print t, "Out", Format$(u, "#,##0")    ' 1.57

Debug.Print tt, "Main Time", Format$(u, "#,##0")            ' 1.03 / 61 719
End Sub