Option Explicit
Function SortArray2D(ByVal sArr, ByVal aCol, Optional bHeader As Boolean = False) As Variant
'Sort Mang 2 chieu "sArr" theo nhieu Cot
'aCol: So hoac Mang so, so duong tu A => Z, so am tu Z => A
'Ví du aCol:' 2: Sort theo cot 2 tu A => Z
' -3: Sort theo cot 3 tu Z => A
'Array(2,-4): (VBA) Sort theo cot 2 tu A => Z và Sort theo cot 4 tu Z => A
'{2,-4}: (Cong thuc trong Sheet) Sort theo cot 2 tu A => Z và Sort theo cot 4 tu Z => A
'bHead = True Du lieu co dong tieu de. Mac dinh bHead = False Du lieu khong co dong tieu de
Dim aRow, Res()
Dim uRow&, sRow&, fRow&, eRow&, fCol&, eCol&, jCol&, b&, i&, r&, n&, k&, j&, fr&
Dim td$, tdUp$, bASC As Boolean, tmp, tmp2
If TypeName(sArr) = "Range" Then sArr = sArr.Value
If IsArray(sArr) = False Then Exit Function
fRow = LBound(sArr, 1): eRow = UBound(sArr, 1)
fCol = LBound(sArr, 2): eCol = UBound(sArr, 2)
If IsArray(aCol) = False Then aCol = Array(aCol) 'Mang thu tu cot Sort
If bHeader Then b = 1
uRow = eRow - fRow - b
ReDim aRow(0 - b To uRow) 'Mang thu tu dong du lieu goc
For i = fRow To eRow
aRow(i - fRow - b) = i
Next i
For n = LBound(aCol) To UBound(aCol)
If n = LBound(aCol) Then 'Sort theo cot dau tien
Call ChiaDuLieu(aRow, sArr, 0, uRow, aCol(n))
Else 'Sort theo cac cot ke tiep
fr = -1
jCol = Abs(aCol(n - 1))
For i = 0 To uRow - 1
tmp = sArr(aRow(i), jCol): tmp2 = sArr(aRow(i + 1), jCol)
If Not IsError(tmp) And Not IsError(tmp2) Then
If fr >= 0 Then
If tmp <> tmp2 Then
Call ChiaDuLieu(aRow, sArr, fr, i, aCol(n))
fr = -1
ElseIf i = uRow - 1 Then
Call ChiaDuLieu(aRow, sArr, fr, uRow, aCol(n))
fr = -1
End If
ElseIf tmp = tmp2 Then
fr = i
End If
End If
Next i
End If
Next n
k = fRow - 1
ReDim Res(fRow To eRow, fCol To eCol) 'Mang ket qua
For i = 0 - b To uRow
k = k + 1
r = aRow(i)
For j = fCol To eCol
Res(k, j) = sArr(r, j)
Next j
Next i
SortArray2D = Res
End Function
Private Sub ChiaDuLieu(aRow, sArr, ByVal fRow&, ByVal eRow&, ByVal jCol&)
' Dim oListStr As Object, oListNum As Object
Dim aErr, aEmp, aNum, aStr, arr
Dim td$, tdUp$, tmp, bASC As Boolean
Dim i&, n&, k0&, k1&, k2&, k3&
Dim oListStr As Object
Dim oListNum As Object
Set oListStr = CreateObject("System.Collections.ArrayList")
Set oListNum = CreateObject("System.Collections.ArrayList")
arr = Array(-1, -1, -1, -1) ' Loi, Rong, So, Chuoi
td = ChrW(273): tdUp = ChrW(272)
bASC = jCol > 0: jCol = Abs(jCol)
For n = fRow To eRow 'Dem cac loai du lieu
tmp = sArr(aRow(n), jCol)
If IsError(tmp) Then 'du lieu error
arr(0) = arr(0) + 1
ElseIf IsEmpty(tmp) Then 'du lieu Rong
arr(1) = arr(1) + 1
ElseIf IsNumeric(tmp) = True Then 'du lieu So
arr(2) = arr(2) + 1
Else 'du lieu Chuoi
arr(3) = arr(3) + 1
End If
Next n
If arr(0) >= 0 Then ReDim aErr(0 To arr(0))
If arr(1) >= 0 Then ReDim aEmp(0 To arr(1))
If arr(2) >= 0 Then ReDim aNum(0 To arr(2))
If arr(3) >= 0 Then ReDim aStr(0 To arr(3))
For n = fRow To eRow 'Gan cac loai du lieu vao mang tuong ung
i = aRow(n)
tmp = sArr(i, jCol)
If IsError(tmp) Then
k0 = k0 + 1: aErr(k0 - 1) = i
ElseIf IsEmpty(tmp) Then
k1 = k1 + 1: aEmp(k1 - 1) = i
ElseIf IsNumeric(tmp) = True Then
k2 = k2 + 1: aNum(k2 - 1) = i
oListNum.Add tmp
Else
If InStr(1, tmp, td, vbBinaryCompare) > 0 Then tmp = Replace(tmp, td, "dzz")
If InStr(1, tmp, tdUp, vbBinaryCompare) > 0 Then tmp = Replace(tmp, tdUp, "Dzz")
k3 = k3 + 1: aStr(k3 - 1) = i
oListStr.Add tmp
End If
Next n
If k2 > 0 Then aNum = SortRow(oListNum, aNum, bASC) 'Sort du lieu So
If k3 > 0 Then aStr = SortRow(oListStr, aStr, bASC) 'Sort du lieu Chuoi
If bASC Then
arr = Array(aNum, aStr, aErr, aEmp) ' So, Chuoi, Loi, Rong
Else
arr = Array(aStr, aNum, aErr, aEmp) ' Chuoi, So, Loi, Rong
End If
k1 = fRow - 1
For n = 0 To 3
If IsArray(arr(n)) Then
For i = 0 To UBound(arr(n))
k1 = k1 + 1
aRow(k1) = arr(n)(i)
Next i
End If
Next n
Set oListNum = Nothing: Set oListStr = Nothing
End Sub
Private Function SortRow(tList, aSort, bASC)
Dim arr(), sR&, i&, k&, r&, tmp, tmp2, oList As Object
On Error Resume Next
ReDim arr(0 To UBound(aSort))
Set oList = tList.Clone
tList.Sort
If bASC = False Then tList.Reverse
For i = 0 To tList.Count - 1
tmp = tList.Item(i)
r = oList.IndexOf(tmp, 0)
If tmp = tList.Item(i + 1) Then oList.Item(r) = Empty
k = k + 1
arr(k - 1) = aSort(r)
Next i
SortRow = arr
Set oList = Nothing
End Function