Function Sort mảng 2 chiều

Chia sẻ bởi:hands

★★★★★

‹ Anh/chị giúp e tách cột TK của... Add-Ins cho Excel 2007 -2016 32bit và... ›

Quảng cáo

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 đề

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

Ví dụ code gọi Function SortArray2D

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 Sub

Ví dụ công thức trong sheet
Lấ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