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 va Sort theo cot 4 tu Z => A
'{2,-4}: (Cong thuc trong Sheet) Sort theo cot 2 tu A => Z va 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 sRow&, fRow&, eRow&, fCol&, eCol&, b&, i&, r&, k&, j&
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
sRow = eRow - fRow - b
ReDim aRow(0 - b To sRow) 'Mang thu tu dong du lieu goc
For i = fRow To eRow
aRow(i - fRow - b) = i
Next i
Call ChiaDuLieu(aRow, sArr, 0, sRow, aCol(LBound(aCol))) 'Sort theo cot 1
If UBound(aCol) > LBound(aCol) Then 'Sort theo cac cot ke tiep
Call DeQui(sArr, aRow, aCol, LBound(aCol) + 1, 0, sRow)
End If
k = fRow - 1
ReDim Res(fRow To eRow, fCol To eCol) 'Mang ket qua
For i = 0 - b To sRow
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 DeQui(sArr, aRow, aCol, ByVal n&, ByVal fRow&, ByVal eRow&)
Dim tmp, tmp2, i&, fR&, jCol&
jCol = Abs(aCol(n - 1)) 'Thu tu cot da Sort truoc
fR = -1
tmp = sArr(aRow(fRow), jCol)
If IsError(tmp) Then tmp = "Error!@#"
For i = fRow To eRow - 1
If i > 0 Then tmp = tmp2
tmp2 = sArr(aRow(i + 1), jCol)
If IsError(tmp2) Then tmp2 = "Error!@#"
If fR = -1 Then
If tmp = tmp2 Then fR = i
End If
If fR > -1 Then
If tmp <> tmp2 Then
Call ChiaDuLieu(aRow, sArr, fR, i, aCol(n))
If n < UBound(aCol) Then
Call DeQui(sArr, aRow, aCol, n + 1, fR, i) 'Sort cot ke tiep
End If
fR = -1
ElseIf i = eRow - 1 Then
Call ChiaDuLieu(aRow, sArr, fR, eRow, aCol(n))
If n < UBound(aCol) Then
Call DeQui(sArr, aRow, aCol, n + 1, fR, eRow) 'Sort cot ke tiep
End If
End If
End If
Next i
End Sub
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&
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) As Variant
Dim Arr(), i&, k&, r&, tmp, 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
