Function Sort2DArray(ByVal SourceArray, ByVal ColIndex As Long, ByVal Order As Boolean, ByVal HasTitle As Boolean)
Dim tmpArr, i As Long, j As Long, SortArr, Item1, Item2, firstVal As Double
Dim Arr, iR As Long, tmp(), n As Long, Chk As Boolean
On Error Resume Next
tmpArr = SourceArray: Arr = tmpArr
ColIndex = ColIndex + LBound(tmpArr, 2) - 1
firstVal = CDbl(tmpArr(LBound(tmpArr, 1) - HasTitle, ColIndex))
Chk = firstVal > 0
For i = LBound(tmpArr, 1) - HasTitle To UBound(tmpArr, 1)
ReDim Preserve tmp(n)
If Chk Then
tmp(n) = CDbl(tmpArr(i, ColIndex))
Else
tmp(n) = CStr(tmpArr(i, ColIndex))
End If
n = n + 1
Next
SortArr = Sort1DArray(tmp, Order)
With CreateObject("Scripting.Dictionary")
For i = LBound(SortArr) To UBound(SortArr)
If Chk Then
If Not .Exists(CDbl(SortArr(i))) Then .Add CDbl(SortArr(i)), i + LBound(tmpArr, 1) - HasTitle
Else
If Not .Exists(CStr(SortArr(i))) Then .Add CStr(SortArr(i)), i + LBound(tmpArr, 1) - HasTitle
End If
Next
For i = LBound(tmpArr, 1) - HasTitle To UBound(tmpArr, 1)
If Chk Then
iR = .Item(CDbl(tmpArr(i, ColIndex)))
Else
iR = .Item(CStr(tmpArr(i, ColIndex)))
End If
For j = LBound(tmpArr, 2) To UBound(tmpArr, 2)
Arr(iR, j) = tmpArr(i, j)
Next
If Chk Then
.Item(CDbl(tmpArr(i, ColIndex))) = iR + 1
Else
.Item(CStr(tmpArr(i, ColIndex))) = iR + 1
End If
Next
End With
Sort2DArray = Arr
End Function
Function Sort1DArray(ByVal srcArr, ByVal Order As Boolean)
Dim Item, tmpArr, Arr1, Arr2, n As Long, m As Long
tmpArr = srcArr
With CreateObject("System.Collections.ArrayList")
For Each Item In tmpArr
.Add Item
Next
.Sort
Arr1 = .ToArray
If Order = False Then
ReDim Arr2(LBound(Arr1) To UBound(Arr1))
For n = .Count To 1 Step -1
Arr2(m) = Arr1(n - 1)
m = m + 1
Next
Sort1DArray = Arr2
Else
Sort1DArray = Arr1
End If
End With
End Function
Function Unique2DArray(ByVal SourceArray, Optional ByVal ColIndex As Variant = 1)
Dim aSrc, aCol, tmp As String, cItem
Dim lR As Long, lC As Long, lUB1 As Long, lUB2 As Long, lLB1 As Long, lLB2 As Long, n As Long
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
aSrc = SourceArray: aCol = ColIndex
If Not IsArray(aCol) Then aCol = Array(aCol)
lLB1 = LBound(aSrc, 1): lLB2 = LBound(aSrc, 2)
lUB1 = UBound(aSrc, 1): lUB2 = UBound(aSrc, 2)
ReDim aDes(1 To lUB2 + 1 - lLB2, 1 To 1)
For lR = lLB1 To lUB1
tmp = vbNullString
If Len(CStr(aSrc(lR, 1))) Then
For Each cItem In aCol
tmp = tmp & vbBack & aSrc(lR, cItem)
Next
If Not dic.Exists(tmp) Then
n = n + 1
dic.Add tmp, lR
ReDim Preserve aDes(1 To lUB2 + 1 - lLB2, 1 To n)
For lC = lLB2 To lUB2
aDes(lC, n) = aSrc(lR, lC)
Next
End If
End If
Next
If n Then Unique2DArray = Transpose2DArray(aDes)
End Function
Function Transpose2DArray(ByVal SourceArray)
Dim aSrc
Dim lR As Long, lC As Long
aSrc = SourceArray
ReDim aDes(LBound(aSrc, 2) To UBound(aSrc, 2), LBound(aSrc, 1) To UBound(aSrc, 1))
For lR = LBound(aSrc, 1) To UBound(aSrc, 1)
For lC = LBound(aSrc, 2) To UBound(aSrc, 2)
aDes(lC, lR) = aSrc(lR, lC)
Next
Next
Transpose2DArray = aDes
End Function