Function Sort mảng 2 chiều

Liên hệ QC

HieuCD

Chuyên gia GPE
Tham gia
14/9/10
Bài viết
9,836
Được thích
23,427

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
Ví dụ code gọi Function SortArray2D
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 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
 

File đính kèm

  • SortMang2.xlsm
    30.5 KB · Đọc: 99
Chỉnh sửa lần cuối bởi điều hành viên:
Bác @HieuCD xem lại thử cái cột thứ 2 không được sắp xếp. Tham số là âm hay dương gì nó cũng để nguyên, không có thứ tự gì cả (tôi chưa thử cột thứ 3)

File dữ liệu tôi test hàm đính kèm
 

File đính kèm

  • SortMang_HieuCD.xlsm
    79.8 KB · Đọc: 14
Upvote 0
Bác @HieuCD xem lại thử cái cột thứ 2 không được sắp xếp. Tham số là âm hay dương gì nó cũng để nguyên, không có thứ tự gì cả (tôi chưa thử cột thứ 3)

File dữ liệu tôi test hàm đính kèm
Cám ơn bạn, code nhầm điều kiện chỉnh lại
Mã:
          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
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 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&
 
  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
 
Upvote 0
Cột thứ 2 ổn rồi, nhờ bác xem tiếp cột thứ 3! Nó cũng như tình trạng của cột 2 trước đây.
 
Upvote 0
Cột thứ 3 chỉ có giá trị duy nhất là Null nên code không sort
Ý tôi là cột thứ 3 được chỉ định trong mảng cột kia. Với data đó tôi chỉ định Array(3, 1, 4), tất nhiên 3 với 1 là xong rồi nhưng với cột 4 thì không sắp được.
 
Upvote 0
Ý tôi là cột thứ 3 được chỉ định trong mảng cột kia. Với data đó tôi chỉ định Array(3, 1, 4), tất nhiên 3 với 1 là xong rồi nhưng với cột 4 thì không sắp được.
Code sort được mờ, bạn chạy lần lượt 2 sub Test sẽ dể thấy hơn
Mã:
Sub TesT()
    Dim Arr
    Arr = Sheet2.Range("A2:D805").Value
    Arr = SortArray2D(Arr, Array(3, 1, 4), False)
    Sheet3.Range("A2").Resize(UBound(Arr, 1), UBound(Arr, 2)) = Arr
End Sub

Sub TesT2()
    Dim Arr
    Arr = Sheet2.Range("A2:D805").Value
    Arr = SortArray2D(Arr, Array(3, 1, -4), False)
    Sheet3.Range("A2").Resize(UBound(Arr, 1), UBound(Arr, 2)) = Arr
End Sub
 

File đính kèm

  • SortMang_HieuCD.xlsm
    85.8 KB · Đọc: 20
Upvote 0
Nếu bác sort cột 2 thì so sánh cột 1 là ok, còn bác sort cột 3 thì phải so sánh luôn cột 1 với cột 2, theo code của bác thì sort cột 3 chỉ so sánh cột 2 là không chính xác.


1​
3​
5​
1​
3​
5​
1​
3​
5​
2​
3​
4​
2​
3​
4​
2​
3​
4​

Nếu dữ liệu như trên thì code của bác sẽ chạy không đúng.
 
Upvote 0
Nếu bác sort cột 2 thì so sánh cột 1 là ok, còn bác sort cột 3 thì phải so sánh luôn cột 1 với cột 2, theo code của bác thì sort cột 3 chỉ so sánh cột 2 là không chính xác.


1​
3​
5​
1​
3​
5​
1​
3​
5​
2​
3​
4​
2​
3​
4​
2​
3​
4​

Nếu dữ liệu như trên thì code của bác sẽ chạy không đúng.
Với dữ liệu trên bạn sort các cột như thế nào và kết quả đúng sẽ là gì, bạn gởi lại để mình kiểm tra
 
Upvote 0
Code sort được mờ, bạn chạy lần lượt 2 sub Test sẽ dể thấy hơn
Nếu cột toàn NULL đó xếp đầu tiên thì không phát sinh vấn đề nhưng khi tôi thay đổi vài dòng thành giá trị khác thì có vấn đề. Bác chạy thử 2 cái Sub TesT và TesT2 trong file đi bác, chỉ thay đổi Array(1, 3, -4) thành Array(1, -3, -4) thôi là cột 1 lẽ ra không liên quan thì lại sắp xếp sai.
 

File đính kèm

  • SortMang_HieuCD.xlsm
    102.1 KB · Đọc: 11
Lần chỉnh sửa cuối:
Upvote 0
Nếu cột toàn NULL đó xếp đầu tiên thì không phát sinh vấn đề nhưng khi tôi thay đổi vài dòng thành giá trị khác thì có vấn đề. Bác chạy thử 2 cái Sub TesT và TesT2 trong file đi bác, chỉ thay đổi Array(1, 3, -4) thành Array(1, -3, -4) thôi là cột 1 lẽ ra không liên quan thì lại sắp xếp sai.
Em sort theo thứ tự {1,2,3}, kết quả không giống Excel Sort
View attachment 258518
Sort lần 3 chưa xét đủ điều kiện, chỉnh lại code
Mã:
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
      For j = LBound(aCol) To n - 1
        tmp = tmp & "|" & sArr(aRow(0), Abs(aCol(j)))
      Next j
      For i = 0 To uRow - 1
        If i > 0 Then tmp = tmp2
        tmp2 = Empty
        For j = LBound(aCol) To n - 1
          If IsError(sArr(aRow(i + 1), Abs(aCol(j)))) Then
            tmp2 = tmp2 & "|error"
          Else
            tmp2 = tmp2 & "|" & sArr(aRow(i + 1), Abs(aCol(j)))
          End If
        Next j
        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
 
Upvote 0
Cám ơn bạn nhiều
Chỉnh code
Mã:
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 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
      For j = LBound(aCol) To n - 1
        tmp = tmp & "|" & sArr(aRow(0), Abs(aCol(j)))
      Next j
      For i = 0 To uRow - 1
        If i > 0 Then tmp = tmp2
        tmp2 = Empty
        For j = LBound(aCol) To n - 1
          If IsError(sArr(aRow(i + 1), Abs(aCol(j)))) Then
            tmp2 = tmp2 & "|error"
          Else
            tmp2 = tmp2 & "|" & sArr(aRow(i + 1), Abs(aCol(j)))
          End If
        Next j
        If Not IsError(tmp) And Not IsError(tmp2) Then
          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))
              fr = -1
            ElseIf i = uRow - 1 Then
              Call ChiaDuLieu(aRow, sArr, fr, uRow, aCol(n))
              fr = -1
            End If
          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
Code vẫn còn khả năng tăng tốc nếu dùng thêm hàm đệ quy cho các lần sort theo cột thứ 2 trở đi
 
Upvote 0
Cám ơn bạn nhiều
Chỉnh code
Mã:
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 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
      For j = LBound(aCol) To n - 1
        tmp = tmp & "|" & sArr(aRow(0), Abs(aCol(j)))
      Next j
      For i = 0 To uRow - 1
        If i > 0 Then tmp = tmp2
        tmp2 = Empty
        For j = LBound(aCol) To n - 1
          If IsError(sArr(aRow(i + 1), Abs(aCol(j)))) Then
            tmp2 = tmp2 & "|error"
          Else
            tmp2 = tmp2 & "|" & sArr(aRow(i + 1), Abs(aCol(j)))
          End If
        Next j
        If Not IsError(tmp) And Not IsError(tmp2) Then
          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))
              fr = -1
            ElseIf i = uRow - 1 Then
              Call ChiaDuLieu(aRow, sArr, fr, uRow, aCol(n))
              fr = -1
            End If
          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
Code vẫn còn khả năng tăng tốc nếu dùng thêm hàm đệ quy cho các lần sort theo cột thứ 2 trở đi
Hay quá, còn khả năng thì tiếp đi bạn.
 
Upvote 0
@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 [A1:D1000] 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.
 
Upvote 0
@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 [A1:D1000] 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.
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, hàm SortArray2D phục vụ chủ yếu sort mảng trong code VBA, cần sort ngang theo cột thì tự viết thêm lệnh chuyển hàng và cột, viết code phải kiểm soát được các tham số, người dùng tự nhập thứ tự cột theo mình là cần thiết, nhập sai báo lỗi, giá trị rổng và lỗi luôn nằm cuối là ý của mình phù hợp với thông lệ, code dài nhằm tăng tốc xử lý khi dữ liệu lớn
 
Upvote 0
Web KT

Bài viết mới nhất

Back
Top Bottom