Function Sort mảng 2 chiều

[HieuCD]

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

 

[VetMini]

Mình không có ý định gộp nhiều chức năng không thực sự cần thiết vào 1 hàm, ...

Theo nguyên tắc KISS (Keep It Simple, Stupid), nếu hàm có thể gói gọn được trong một chức năng thì cứ việc gói gọn. Nếu cần nhiều chức năng thì có thể viết hàm khác, hoặc viết cái hàm bao (wrapper function) nó chọn lựa, chỉnh đổi đầu vào.

Bạn chỉ cần đa năng khi bạn muốn buôn bán hoặc quảng cáo. Thường thì người rước ba cái mớ đa năng này về cũng viết thêm mấy cái hàm bao để đơn giản hoá lúc gọi.
Vì dụ tôi có cái hàm có thể sort ngang và/hoặc dọc thì tôi viết thêm 2 hàm để gọi hàm này: SortDoc, SortNgang.
Nếu vì lý do nào đó, tôi đọc code và hiểu rằng hàm có khả năng vừa dọc vừa ngang cùng một lúc, hiệu quả hơn thì tôi viết thêm hàm SortDocNgang.

 

[Maika8008]

@HieuCD
Hàm bác viết còn thiếu nhiều ràng buộc để đạt được một hàm đa năng.

Mảng [A11000] 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.
Nếu mảng có nhiều cột mà người dùng muốn xếp từ cột nhỏ đến cột lớn.
Không lẻ phải bắt buộc người dùng nhập {1, 2, 3, 4, 5, 6, 7, 8} hoặc {-8, -7, -6, -5, -4, -3 ,-2, -1}

Hàm sắp xếp mảng ngang.
Sắp xếp giá trị Null luôn luôn ở dưới cùng dù xếp tăng hay giảm dần.

Hàm của bác tận dụng ArrayList nhưng quá dài. Nếu thêm các ràng buộc ở trên chắc còn dài nữa.

Tôi không biết mọi người thế nào chứ với tôi hầu như chưa khi nào có nhu cầu sort quá 3 cột (hoặc còn gọi là 3 tầng). Còn sort mảng trung gian trong thủ tục vba thì chỉ cần 2 cột.

 

[befaint]

sort quá 3 cột

Những người sử dụng bảng tính trải rộng luôn gọi là sắp xếp theo nhiều cột, chứ tầng với lầu thì thua luôn rồi.

Tới Microsoft cũng phải rất rất cẩn trọng khi sử dụng từ ngữ ấy.

 

[HieuCD]

Cập nhật thêm Function SortHoTen tiếng Việt có ghi chú A, B, C cho những tên trùng nhau
Tham số thứ 3 bABC=true khi danh sách có trùng tên và thêm ký tự "A" "B" hoặc "C" để phân biệt, chỉ xét 3 trường hợp "A" "B" "C", code chưa xét chi tiết nên có thể chưa chính xác 100% và sai sót nếu có cũng không nghiêm trọng

Option Explicit
Function SortHoTen(ByVal sArr As Variant, Optional bASC As Boolean = True, Optional bABC As Boolean = False) As Variant
'SortHoTen: Sort Ho Ten tieng Viet, ket qua là mang 2 chieu
'sArr co the la Array 2 chieu hoac Range, voi cac dong la HoTen trinh bay tren 1 cot
'bASC mac dinh = true sort A --> Z, bASC = false Z --> A
'bABC = True có trung ho ten và them A, B, hoac C sau ten de phan biet
'bABC mac dinh = False khong co trung ten
  Dim Arr(), tmp$, t$, sRow&, i&, j&, d&
  If TypeName(sArr) = "Range" Then sArr = sArr.Value 'Chuyen sArr thanh Mang
  If IsArray(sArr) = False Then 'Chuyen sArr thanh Mang
    ReDim Arr(1 To 1, 1 To 1)
    Arr(1, 1) = sArr:    SortHoTen = Arr
    Exit Function
  End If
  sRow = UBound(sArr)
  ReDim Arr(1 To sRow, 1 To 2) 'Cot 1 Ho, cot 2 Ten
  For i = 1 To sRow
    tmp = Application.Trim(sArr(i, 1))
    If tmp <> Empty Then
      j = InStrRev(tmp, " ")
      Arr(i, 2) = Mid(tmp, j + 1, 200) 'Ten
      If bABC = True Then 'Them A, b, hoac C sau Ten bi trung
        t = Right(tmp, 1): d = Len(Arr(i, 2))
        If d > 1 And t = UCase(t) And InStr(1, "ABC", t) > 0 Then 'Trung Ten
          Arr(i, 1) = tmp & "||" 'Ho
          Arr(i, 2) = Mid(Arr(i, 2), 1, Len(Arr(i, 2)) - 1) 'Ten
        Else 'Khong trung
          If j > 0 Then Arr(i, 1) = Mid(tmp, 1, j - 1) 'Ho
        End If
      Else 'Khong co them A, b, hoac C sau Ten
        If j > 0 Then Arr(i, 1) = Mid(tmp, 1, j - 1) 'Ho
      End If
    End If
  Next i
  If bASC = True Then 'Sort A --> Z
    Arr = SortArray2D(Arr, Array(2, 1))
  Else 'Sort Z --> A
    Arr = SortArray2D(Arr, Array(-2, -1))
  End If
  For i = 1 To sRow 'Ket qua Sort
    If InStr(1, Arr(i, 1), "||") Then
      sArr(i, 1) = Replace(Arr(i, 1), "||", "")
    Else
      If Arr(i, 1) = Empty Then
        sArr(i, 1) = Arr(i, 2)
      Else
        sArr(i, 1) = Arr(i, 1) & " " & Arr(i, 2)
      End If
    End If
  Next i
  SortHoTen = sArr
End Function

Sub ví dụ trong sheet 2

Sub Main()
  Dim sArr
  With Sheets("Sheet2")
    sArr = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value
    sArr = SortHoTen(sArr, 1, 1)
    .Range("C2").Resize(UBound(sArr)) = sArr
  End With
End Sub

 

[theanhst92]

.