Function Sort mảng 2 chiều
Trước đây có viết hàm sort mảng 2 chiều bằng cách chuyển dạng số sang dạng chuỗi, nay viết mới toàn bộ và tách dữ liệu thành 4 dạng: Error, Blank, Số và Chuổi, hàm có thể dùng trong code VBA hoặc trực tiếp trên Sheet
Function SortArray2D(ByVal sArr, ByVal aCol, Optional bHeader As Boolean = False) As Variant
- Sort Mảng 2 chiều theo nhiều cột
- Sarr: Mảng 2 chiều, có thể là Range
- aCol: Số hoặc mảng số, số dương sort từ A => Z, số âm sort từ Z => A
Ví dụ: aCol= 2: Sort theo cột 2 từ A => Z
aCol= -3: Sort theo cot 3 từ Z => A
aCol= Array(2,-4): Trong code VBA, Sort theo cột 2 từ A => Z và Sort theo cột 4 từ Z => A
aCol= {2,-4}: Công thứ trong Sheet, Sort theo cột 2 từ A => Z và Sort theo cột 4 từ Z => A
- bHead = True Dữ liệu có dòng tiêu đề, mặc định bHead = False dữ liệu không có dòng tiêu đề
Mã:
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
Mã:
Sub ABC()
Dim sArr(), Res
sArr = Range("B2:E11").Value
Res = SortArray2D(sArr, 1)
Range("G16").Resize(UBound(sArr), 4) = Res
End Sub
Sub ABC2()
Dim sArr(), Res
sArr = Range("B1:E11").Value
Res = SortArray2D(sArr, Array(-2, 3), True)
Range("L15").Resize(UBound(sArr), 4) = Res
End SubLấy kết quả toàn bộ mảng xếp thứ tự theo cột 1:
=SortArray2D($B$2:$E$11,1)
Lấy kết quả dòng 3 cột 1 của mảng xếp thứ tự từ lớn đến nhỏ cột 2 và từ nhỏ đến lớn cột 3:
=INDEX(SortArray2D($B$1:$E$11,{-2,3},TRUE),3,1)
Với ý đồ tăng tốc độ xử lý nên code khá dài dòng, code khó tránh khỏi thiếu sót mong các bạn góp ý hoàn thiện function
Chúc các bạn vui khỏe
Ghi chú: Code cập nhật xử lý đệ qui nhằm tăng tốc Function, điều chỉnh thứ tự cột sort trong công thức trực tiếp trên sheet
Chỉnh sửa lần cuối bởi điều hành viên:
1000] nếu vô tình nhập {0, 5, 3, 2} thì lỗi. Vì giá trì cột nằm ngoài vùng.
