Hàm sắp xếp mảng ngang dọc với Thuật toán QuickSort (sắp xếp Tiếng Việt) cho Excel

Liên hệ QC MyVTV Add-ins

Hàm sắp xếp mảng ngang dọc với Thuật toán QuickSort (sắp xếp Tiếng Việt) cho Excel​

https://www.giaiphapexcel.com/diendan/forums/lập-trình-với-excel.79/post-thread

Hôm nay tôi lại chia sẻ cho các bạn các Hàm UDF được viết bằng VBA, nhằm mục đích để sắp xếp mảng một cách tối ưu nhất.

HÀM UDF SẮP XẾP PHÂN TẦNG (ĐA HÀNG ĐA CỘT)


  1. Hàm S_SortV - Hàm trả lại mảng Sắp xếp dọc, Hàm S_SortVW là hàm ghi ra mảng cho bảng tính Excel
  2. Hàm S_SortH - Hàm trả lại mảng Sắp xếp ngang, Hàm S_SortHW là hàm ghi ra mảng cho bảng tính Excel
Hàm S_SortVW và hàm S_SortHW là hai hàm tự động ghi ra mảng ra bảng tính hoàn toàn sau khi gõ hàm, giá trị vùng thay đổi thì hàm thực thi.


Mục tiêu đạt được:
  1. Sắp xếp cả mảng ngang và mảng dọc.
  2. Sắp xếp phân tầng (đa cột).
  3. Sắp xếp Tiếng Việt.
  4. Giao diện đẹp mắt.
Hướng dẫn sử dụng hàm:

Vị tríTham sốKiểuChức năng
1​
CellsVùng cần tổngNhận vùng cần sắp xếp
2​
Columns / RowsSố cột hoặc Mảng các cộtNếu nhập số âm thì sắp xếp giảm dần, bằng 0 sx tất cả, -99999 xs từ cột cuối
3​
MatchCaseCó/KhôngSắp xếp không phân biệt hoa thường
4​
HeaderCó/KhôngVùng có đầu đề
5​
colorSốMàu, Nếu đặt màu nhỏ hơn 0 thì không tô màu
6​
TargetVùng tô màuVùng trả kết quả
7​
NaturalStartingSốVị trí bắt đầu phân màu
8​
NaturalFactorSốTỉ lệ phân màu
9​
DefaultFontColorSốMàu phông chữ mặc định
10​
DefaultBackColorSốMàu nền mặc đinh


Ví dụ viết hàm vào bảng tính (sắp xếp dọc):
1. Sắp xếp mảng A2:Z10000 với các phân tầng là tất cả cột, lớn dần
=S_SortVW(A2:Z10000, 0, FALSE)
2. Sắp xếp mảng A2:Z10000 với cột thứ 3, lớn dần gõ 3, nhỏ dần gõ -3
=S_SortVW(A2:Z10000, 3, FALSE)
3. Sắp xếp mảng A2:Z10000 với các phân tầng là 1, 3, 5, 7 (thứ tự cột), lớn dần
=S_SortVW(A2:Z10000, {1, 3, 5, 7}, FALSE)
4. Sắp xếp mảng A2:Z10000 với các phân tầng là 8, 3, 5, 4 (thứ tự cột), lớn dần
=S_SortVW(A2:Z10000, {8, 3, 5, 4}, FALSE)
5. Sắp xếp mảng A2:Z10000 với các phân tầng là -8, -3, -5, -4 (thứ tự cột), giảm dần
=S_SortVW(A2:Z10000, {-8, -3, -5, -4}, FALSE)

Ví dụ sắp xếp ngang tương tự chỉ đổi Hàm

Ví dụ viết code VBA với S_SortV và S_SortH:
PHP:
Dim Arr
Arr =S_SortV([A2:Z10000], 0, FALSE)



QuickSort Highlight Color - Excel UDF


Các bạn có thể tham khảo thêm hàm sắp xếp mảng khác:

Các bạn muốn học VBA nhanh nhất có thể hãy tham khảo tool hỗ trợ lập trình VBA:
 

File đính kèm

  • S_QSort_Color.xlsm
    482.8 KB · Đọc: 13
Chỉnh sửa lần cuối bởi điều hành viên:
Hôm nay tôi lại chia sẻ cho các bạn các Hàm UDF được viết bằng VBA, nhằm mục đích để sắp xếp mảng một cách tối ưu nhất.

HÀM UDF SẮP XẾP PHÂN TẦNG (ĐA CỘT)


  1. Hàm S_SortV - Hàm trả lại mảng Sắp xếp dọc, Hàm S_SortVW là hàm ghi ra mảng cho bảng tính Excel
  2. Hàm S_SortH - Hàm trả lại mảng Sắp xếp ngang, Hàm S_SortHW là hàm ghi ra mảng cho bảng tính Excel
Hàm S_SortVW và hàm S_SortHW là hai hàm tự động ghi ra mảng ra bảng tính hoàn toàn sau khi gõ hàm, giá trị vùng thay đổi thì hàm thực thi.


Mục tiêu đạt được:
  1. Sắp xếp cả mảng ngang và mảng dọc.
  2. Sắp xếp phân tầng (đa cột)
  3. Sắp xếp Tiếng Việt
  4. Tốc độ nhanh nhất.
Hướng dẫn sử dụng hàm:

Vị trí
Tham số
Kiểu
Chức năng
1
Cells
Vùng cần tổng
Nhận vùng cần sắp xếp
2
Columns / Rows
Số cột hoặc Mảng các cột
nhập thứ tự cột hoặc mảng thứ tự hoặc không nhập
3
sortDescending
Có/Không
Sắp xếp theo thứ tự giảm dần

Ví dụ viết hàm vào bảng tính (sắp xếp dọc):
1. Sắp xếp mảng A2:Z10000 với các phân tầng là tất cả cột, lớn dần
=S_SortVW(A2:Z10000, -1, FALSE)
2. Sắp xếp mảng A2:Z10000 với cột thứ 3, lớn dần
=S_SortVW(A2:Z10000, 3, FALSE)
3. Sắp xếp mảng A2:Z10000 với các phân tầng là 1, 3, 5, 7 (thứ tự cột), lớn dần
=S_SortVW(A2:Z10000, {1, 3, 5, 7}, FALSE)
4. Sắp xếp mảng A2:Z10000 với các phân tầng là 8, 3, 5, 4 (thứ tự cột), lớn dần
=S_SortVW(A2:Z10000, {8, 3, 5, 4}, FALSE)

Ví dụ sắp xếp ngang tương tự chỉ đổi Hàm

Ví dụ viết code VBA với S_SortV và S_SortH:
PHP:
Dim Arr
Arr =S_SortV([A2:Z10000], -1, FALSE)

Code hàm sắp xếp S_SortV và S_SortH:
PHP:
Option Explicit

Private Sub S_Sort_random()
  Dim rg, r, c, a
  Set rg = Sheet1.Range("C4").Resize(100, 10)
  a = rg.Value
  VBA.Randomize
  For r = 1 To UBound(a)
    For c = 1 To UBound(a, 2)
      a(r, c) = Int(VBA.Rnd * 4) + 1
    Next
  Next
  rg.Value = a


  Set rg = Sheet1.Range("AA5").Resize(4, 20)
  a = rg.Value
  For r = 1 To UBound(a)
    For c = 1 To UBound(a, 2)
      a(r, c) = Int(VBA.Rnd * 4) + 1
    Next
  Next
  rg.Value = a
End Sub

Private Sub S_SortV_test()
  Dim b, a(1 To 10, 1 To 3), i%, j%: i = 1
'  a(i, 1) = "z": a(i, 2) = 1: a(i, 3) = 1: i = i + 1
'  a(i, 1) = "z": a(i, 2) = 2: a(i, 3) = 2: i = i + 1
'  a(i, 1) = "z": a(i, 2) = 2: a(i, 3) = 4: i = i + 1
'  a(i, 1) = "z": a(i, 2) = 2: a(i, 3) = 5: i = i + 1
'  a(i, 1) = "a": a(i, 2) = 1: a(i, 3) = 1: i = i + 1
'  a(i, 1) = "a": a(i, 2) = 2: a(i, 3) = 1: i = i + 1
'  a(i, 1) = "a": a(i, 2) = 5: a(i, 3) = 1: i = i + 1
'  a(i, 1) = ChrW(272): a(i, 2) = 2: a(i, 3) = 1: i = i + 1
'  a(i, 1) = ChrW(272): a(i, 2) = 4: a(i, 3) = 1: i = i + 1
'  a(i, 1) = ChrW(272): a(i, 2) = 1: a(i, 3) = 1: i = i + 1
  b = S_Sortv(Sheet1.[B4:F203].Value)

End Sub

Function S_Sortv(ByVal SortArray, Optional ByVal Columns = -1, Optional ByVal sortDescending As Boolean)
  On Error GoTo E
  Dim a(), b(), x(), w(), ww(), iw&, iww&, k&, Min&, c&, r&, i&, l&, u&, z()
  Dim lb%, ub&, lb2%, ub2&, Compare As VbCompareMethod
  Dim lv%, lcol&, col&, v, lines&, fline&, nb&
  Dim t1$, t2$, t3$, t4$, it As Boolean
  GoSub i
  QuickSortZV SortArray, a, col, , , Compare
  If u > l Then
    fline = lb: lines = ub: lcol = l - 1: col = l: GoSub l
    If iw > 0 Then
      For lv = l + 1 To u
        lcol = Columns(lv - 1): col = Columns(lv)
        If iw > 0 Then
          ww = w: iw = 0: Erase w
          For iww = 1 To UBound(ww, 2)
            i = ww(1, iww)
            fline = 1
            lines = ww(2, iww)
            b = ww(3, iww)
            Compare = ww(4, iww)
            QuickSortZV SortArray, b, col, , , Compare
            GoSub l
          Next
        End If
      Next
    End If
  End If
  GoSub z
Exit Function
l:
  k = 0
  For r = fline To lines
    If i > 0 Then
      nb = r + i - 1
      a(nb) = b(r)
    Else
      nb = r
    End If
    If lv < u Then
      t1 = SortArray(a(nb), lcol + 1)
      If k > 0 Then
        If t2 <> t1 Then
          If k > 1 And it Then
            GoSub w
          End If
          GoTo l2
        Else
          If Not it Then
            t3 = SortArray(a(nb), col + 1)
            If t4 <> t3 Then
              it = True
            End If
          End If
        End If
      Else
l2:     k = 0: Min = nb: t4 = SortArray(a(nb), col + 1): it = False
      End If
      k = k + 1: GoSub fw
      t2 = t1
    End If
  Next
  If k > 1 And it Then
    GoSub w
  End If
Return
fw:
  ReDim Preserve x(1 To k)
  x(k) = a(nb)
  If Compare = 0 Then
    v = SortArray(a(nb), col + 1)
    If Not IsNumeric(v) And Not IsDate(v) And v <> vbNullString Then
      Compare = 1
    End If
  End If
Return
w:
  iw = iw + 1
  ReDim Preserve w(1 To 4, 1 To iw)
  w(1, iw) = Min
  w(2, iw) = k
  w(3, iw) = x
  w(4, iw) = Compare: Compare = 0
Return
i:
  lb = LBound(SortArray)
  ub = UBound(SortArray)
  lb2 = LBound(SortArray, 2)
  ub2 = UBound(SortArray, 2)

  If IsNumeric(Columns) Then
    If Columns < lb2 Then
      ReDim z(lb2 To ub2)
      For col = lb2 To ub2
        z(col) = col
      Next
      Columns = z
      l = lb2
      u = ub2
      col = Columns(l)
    ElseIf Columns > ub2 Then
      S_Sortv = SortArray
      Exit Function
    Else
      c = Columns
    End If
  ElseIf IsArray(Columns) Then
    l = LBound(Columns)
    u = UBound(Columns)
    col = Columns(l)
  Else
    Exit Function
  End If

  ReDim a(lb To ub)
  For r = lb To ub
    a(r) = r
    If Compare = 0 Then
      v = SortArray(r, col)
      If Not IsNumeric(v) And Not IsDate(v) And v <> vbNullString Then
        Compare = 1
      End If
    End If
  Next
Return
z:
  ReDim z(lb To ub, lb2 To ub2)
  If sortDescending Then
    For r = lb To ub
      For c = lb2 To ub2
        z(r, c) = SortArray(a(ub - r + 1), c)
      Next
    Next
  Else
    For r = lb To ub
      For c = lb2 To ub2
        z(r, c) = SortArray(a(r), c)
      Next
    Next
  End If
  S_Sortv = z
Return
E: S_Sortv = SortArray
End Function


Private Sub QuickSortZV_test()
  Debug.Print StrComp(ChrW(272), ChrW(273), 1), ChrW(272) < ChrW(273)
  Debug.Print StrComp(ChrW(272), ChrW(273), 1) = 0 And ChrW(272) < ChrW(273)
End Sub
Sub QuickSortZV( _
              ByVal SortArray As Variant, _
                    ArrayTemp(), _
            Optional lngColumn& = -1, _
            Optional lngMin& = -1, _
            Optional lngMax& = -1, _
            Optional Compare As VbCompareMethod = VbCompareMethod.vbBinaryCompare)

  On Error Resume Next
  Dim i&, j&, varMid, Temp
  Dim lngColTemp As Long
  If IsEmpty(SortArray) Then Exit Sub
  If InStr(TypeName(SortArray), "()") < 1 Then Exit Sub
  If lngMin = -1 Then lngMin = LBound(ArrayTemp, 1)
  If lngMax = -1 Then lngMax = UBound(ArrayTemp, 1)
  If lngMin >= lngMax Then Exit Sub

  i = lngMin: j = lngMax
  varMid = Empty: varMid = SortArray(ArrayTemp((lngMin + lngMax) \ 2), lngColumn)
  If IsEmpty(varMid) Then
    i = lngMax: j = lngMin
  ElseIf IsNull(varMid) Then
    i = lngMax: j = lngMin
  ElseIf varMid = vbNullString Then
    i = lngMax: j = lngMin
  ElseIf VarType(varMid) = vbError Then
    i = lngMax: j = lngMin
  ElseIf VarType(varMid) > 17 Then
    i = lngMax: j = lngMin
  End If

  If Compare = vbBinaryCompare Then
    While i <= j
      While SortArray(ArrayTemp(i), lngColumn) < varMid And i < lngMax: i = i + 1: Wend
      While varMid < SortArray(ArrayTemp(j), lngColumn) And j > lngMin: j = j - 1: Wend
      If i <= j Then
Swap1:   Temp = ArrayTemp(i): ArrayTemp(i) = ArrayTemp(j): ArrayTemp(j) = Temp
        i = i + 1: j = j - 1
      End If
    Wend
  Else
    While i <= j
      While (StrComp(SortArray(ArrayTemp(i), lngColumn), varMid, 1) = -1 Or (SortArray(ArrayTemp(i), lngColumn) > varMid) And StrComp(SortArray(ArrayTemp(i), lngColumn), varMid, 1) = 0) And i < lngMax: i = i + 1: Wend
      While (StrComp(varMid, SortArray(ArrayTemp(j), lngColumn), 1) = -1 Or (varMid > SortArray(ArrayTemp(j), lngColumn)) And StrComp(varMid, SortArray(ArrayTemp(j), lngColumn), 1) = 0) And j > lngMin: j = j - 1: Wend
      If i <= j Then
Swap2:   Temp = ArrayTemp(i): ArrayTemp(i) = ArrayTemp(j): ArrayTemp(j) = Temp
        i = i + 1: j = j - 1
      End If
    Wend
  End If
  If (lngMin < j) Then Call QuickSortZV(SortArray, ArrayTemp, lngColumn, lngMin, j, Compare)
  If (i < lngMax) Then Call QuickSortZV(SortArray, ArrayTemp, lngColumn, i, lngMax, Compare)
End Sub


Private Sub S_SortH_test()
  Dim a, i, j
  a = S_SortH(Sheet1.[O4:AH8].Value, -1, False)
End Sub

Function S_SortH(ByVal SortArray, Optional Rows = 0, Optional sortDescending As Boolean)
'On Error GoTo E
  Dim a(), b(), x(), w(), ww(), iw&, iww&, k&, Min&, c&, r&, i&, l&, u&, z()
  Dim lb%, ub&, lb2%, ub2&, Compare As VbCompareMethod
  Dim lv%, lrow&, row&, v, lines&, fline&, nb&
  Dim t1$, t2$, t3$, t4$, it As Boolean
  GoSub i
  QuickSortZH SortArray, a, row, , , Compare
  If u > l Then
    fline = lb2: lines = ub2: lrow = l - 1: row = l: GoSub l
    If iw > 0 Then
      For lv = l + 1 To u
        lrow = Rows(lv - 1): row = Rows(lv)
        If iw > 0 Then
          ww = w: iw = 0: Erase w
          For iww = 1 To UBound(ww, 2)
            i = ww(1, iww)
            fline = 1
            lines = ww(2, iww)
            b = ww(3, iww)
            Compare = ww(4, iww)
            QuickSortZH SortArray, b, row, , , Compare
            GoSub l
          Next
        End If
      Next
    End If
  End If
  GoSub z
Exit Function
l:
  k = 0
  For c = fline To lines
    If i > 0 Then
      nb = c + i - 1
      a(nb) = b(c)
    Else
      nb = c
    End If
    If lv < u Then
      t1 = SortArray(lrow + 1, a(nb))
      If k > 0 Then
        If t2 <> t1 Then
          If k > 1 And it Then
            GoSub w
          End If
          GoTo l2
        Else
          If Not it Then
            t3 = SortArray(row + 1, a(nb))
            If t4 <> t3 Then
              it = True
            End If
          End If
        End If
      Else
l2:     k = 0: Min = nb: t4 = SortArray(row + 1, a(nb)): it = False
      End If
      k = k + 1: GoSub fw
      t2 = t1
    End If
  Next
  If k > 1 And it Then
    GoSub w
  End If
Return
fw:
  ReDim Preserve x(1 To k)
  x(k) = a(nb)
  If Compare = 0 Then
    v = SortArray(row + 1, a(nb))
    If Not IsNumeric(v) And Not IsDate(v) And v <> vbNullString Then
      Compare = 1
    End If
  End If
Return
w:
  iw = iw + 1
  ReDim Preserve w(1 To 4, 1 To iw)
  w(1, iw) = Min
  w(2, iw) = k
  w(3, iw) = x
  w(4, iw) = Compare: Compare = 0
Return
i:
  lb = LBound(SortArray)
  ub = UBound(SortArray)
  lb2 = LBound(SortArray, 2)
  ub2 = UBound(SortArray, 2)

  If IsNumeric(Rows) Then
    If Rows < lb Then
      ReDim z(lb To ub)
      For row = lb To ub
        z(row) = row
      Next
      Rows = z
      l = lb
      u = ub
      row = Rows(l)
    ElseIf Rows > ub Then
      S_SortH = SortArray
      Exit Function
    Else
      c = Rows
    End If
  ElseIf IsArray(Rows) Then
    l = LBound(Rows)
    u = UBound(Rows)
    row = Rows(l)
  Else
    Exit Function
  End If

  ReDim a(lb2 To ub2)
  For c = lb2 To ub2
    a(c) = c
    If Compare = 0 Then
      v = SortArray(row, c)
      If Not IsNumeric(v) And Not IsDate(v) And v <> vbNullString Then
        Compare = 1
      End If
    End If
  Next
Return
z:
  ReDim z(lb To ub, lb2 To ub2)
  If sortDescending Then
    For r = lb To ub
      For c = lb2 To ub2
        z(r, c) = SortArray(r, a(ub - c + 1))
      Next
    Next
  Else
    For r = lb To ub
      For c = lb2 To ub2
        z(r, c) = SortArray(r, a(c))
      Next
    Next
  End If
  S_SortH = z
Return
E: S_SortH = SortArray
End Function

Sub QuickSortZH( _
              ByVal SortArray As Variant, _
                    ArrayTemp(), _
            Optional lngRow& = -1, _
            Optional lngMin& = -1, _
            Optional lngMax& = -1, _
            Optional Compare As VbCompareMethod = VbCompareMethod.vbBinaryCompare)

  On Error Resume Next
  Dim i&, j&, varMid, Temp
  Dim lngColTemp As Long
  If IsEmpty(SortArray) Then Exit Sub
  If InStr(TypeName(SortArray), "()") < 1 Then Exit Sub
  If lngMin = -1 Then lngMin = LBound(ArrayTemp, 1)
  If lngMax = -1 Then lngMax = UBound(ArrayTemp, 1)
  If lngMin >= lngMax Then Exit Sub

  i = lngMin: j = lngMax
  varMid = Empty: varMid = SortArray(lngRow, ArrayTemp((lngMin + lngMax) \ 2))
  If IsEmpty(varMid) Then
    i = lngMax: j = lngMin
  ElseIf IsNull(varMid) Then
    i = lngMax: j = lngMin
  ElseIf varMid = vbNullString Then
    i = lngMax: j = lngMin
  ElseIf VarType(varMid) = vbError Then
    i = lngMax: j = lngMin
  ElseIf VarType(varMid) > 17 Then
    i = lngMax: j = lngMin
  End If
  If Compare = vbBinaryCompare Then
    While i <= j
      While SortArray(lngRow, ArrayTemp(i)) < varMid And i < lngMax: i = i + 1: Wend
      While varMid < SortArray(lngRow, ArrayTemp(j)) And j > lngMin: j = j - 1: Wend
      If i <= j Then
Swap1:   Temp = ArrayTemp(i): ArrayTemp(i) = ArrayTemp(j): ArrayTemp(j) = Temp
        i = i + 1: j = j - 1
      End If
    Wend
  Else
    While i <= j
      While (StrComp(SortArray(lngRow, ArrayTemp(i)), varMid, 1) = -1 Or (SortArray(lngRow, ArrayTemp(i)) > varMid) And StrComp(SortArray(lngRow, ArrayTemp(i)), varMid, 1) = 0) And i < lngMax: i = i + 1: Wend
      While (StrComp(varMid, SortArray(lngRow, ArrayTemp(j)), 1) = -1 Or (varMid > SortArray(lngRow, ArrayTemp(j))) And StrComp(varMid, SortArray(lngRow, ArrayTemp(j)), 1) = 0) And j > lngMin: j = j - 1: Wend
      If i <= j Then
Swap2:   Temp = ArrayTemp(i): ArrayTemp(i) = ArrayTemp(j): ArrayTemp(j) = Temp
        i = i + 1: j = j - 1
      End If
    Wend
  End If
  If (lngMin < j) Then Call QuickSortZH(SortArray, ArrayTemp, lngRow, lngMin, j, Compare)
  If (i < lngMax) Then Call QuickSortZH(SortArray, ArrayTemp, lngRow, i, lngMax, Compare)
End Sub


Code UDF mảng động S_SortVW và S_SortHW:
PHP:
Option Explicit

Private Type TypeArguments
  Action As Long
  Formula As String
  Cells As Excel.Range
  Caller As Range
  sortDescending As Boolean
  lines As Variant
  Value As Variant
  sortHorizontal As Boolean
End Type

#If VBA7 Then
Option Explicit

Private Type TypeArguments
  Action As Long
  Formula As String
  Cells As Excel.Range
  Caller As Range
  sortDescending As Boolean
  lines As Variant
  Value As Variant
  sortHorizontal As Boolean
End Type

#If VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
''///////////////////////////////////////////////////////
#If VBA7 And Win64 Then
  Private gTimerID As LongPtr
#Else
  Private gTimerID As Long
#End If
''///////////////////////////////////////////////////////
Private Works() As TypeArguments



Function S_SortVW( _
             ByVal Cells As Range, _
    Optional ByVal Columns As Variant = -1, _
    Optional ByVal sortDescending As Boolean = False)
  On Error Resume Next
  If Cells.Worksheet.ProtectContents = True Then
    S_SortVW = "Protect"
    Exit Function
  End If

  Dim r As Object, k%, i%, s$, f$
  s = Cells.Address(0, 0)
  Set r = Application.Caller
  f = r.Formula
  S_SortVW = "wait..."

  k = UBound(Works)
  For i = 1 To k
    With Works(i)
      If .Formula = f Then
        Select Case .Action
        Case 2: S_SortVW = .Value: .Action = 3
          If gTimerID = 0 Then
            gTimerID = SetTimer(0&, 0&, 0, AddressOf S_QSort_finally)
          End If
          Exit Function
        Case Else:
          .sortDescending = sortDescending
          .lines = Columns
          .Action = 0: GoTo n
        End Select
        Exit For
      End If
    End With
  Next
  k = k + 1
  ReDim Preserve Works(1 To k)
  With Works(k)
    Set .Caller = r
    Set .Cells = Cells
    .Formula = f
    .sortDescending = sortDescending
    .lines = Columns
    .sortHorizontal = False
  End With
n:
  Set r = Nothing
  If gTimerID = 0 Then
    gTimerID = SetTimer(0&, 0&, 0, AddressOf S_QSort_callback)
  End If
  On Error GoTo 0
End Function



Function S_SortHW( _
             ByVal Cells As Range, _
    Optional ByVal Rows As Variant = -1, _
    Optional ByVal sortDescending As Boolean = False)


  On Error Resume Next
  If Cells.Worksheet.ProtectContents = True Then
    S_SortHW = "Protect"
    Exit Function
  End If

  Dim r As Object, k%, i%, s$, f$
  s = Cells.Address(0, 0)
  Set r = Application.Caller
  f = r.Formula

  S_SortHW = "wait..."
  k = UBound(Works)
  For i = 1 To k
    With Works(i)
      If .Formula = f Then
        Select Case .Action
        Case 2: S_SortHW = .Value: .Action = 3
          If gTimerID = 0 Then
            gTimerID = SetTimer(0&, 0&, 0, AddressOf S_QSort_finally)
          End If
          Exit Function
        Case Else:
          .sortDescending = sortDescending
          .lines = Rows
          .Action = 0: GoTo n
        End Select
        Exit For
      End If
    End With
  Next
  k = k + 1
  ReDim Preserve Works(1 To k)
  With Works(k)
    Set .Caller = r
    Set .Cells = Cells
    .Formula = f
    .sortDescending = sortDescending
    .lines = Rows
    .sortHorizontal = True
  End With
n:
  Set r = Nothing
  If gTimerID = 0 Then
    gTimerID = SetTimer(0&, 0&, 0, AddressOf S_QSort_callback)
  End If
  On Error GoTo 0
End Function


Private Sub S_QSort_finally()
  On Error Resume Next
  Call KillTimer(0&, gTimerID): gTimerID = 0
  Dim k%, u%
  u = UBound(Works)
  For k = 1 To u
    If Works(k).Action <> 3 Then
      Exit Sub
    End If
  Next
  If u > 0 Then
    Erase Works
  End If
End Sub

Private Sub S_QSort_callback()
  On Error Resume Next
  Call KillTimer(0&, gTimerID)
  gTimerID = 0
  S_QSort_working
  On Error GoTo 0
End Sub

Private Sub S_QSort_working()
  On Error Resume Next
  Dim ub As Integer, a As Object, b As TypeArguments, i&, k&, su As Boolean, Ac As Boolean, v As Variant
  ub = UBound(Works)
  Dim s$
  For i = 1 To ub
    b = Works(i)
    Select Case b.Action
    Case 0
      If b.Caller.Formula = b.Formula Then
        If a Is Nothing Then
          Set a = b.Cells.Parent.Parent.Parent
          su = a.ScreenUpdating
          Ac = a.Calculation
          If su Then a.ScreenUpdating = False
          If Ac = xlCalculationAutomatic Then a.Calculation = xlCalculationManual
        End If
        Works(i).Action = 1
        Dim LastRow&, LastCol%
        LastRow = b.Cells.Find("*", After:=b.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByRows).row - b.Cells.row + 1
        LastCol = b.Cells.Find("*", After:=b.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column - b.Cells.Column + 1
      
        If LastRow > 0 And LastCol > 0 Then
          If b.sortHorizontal Then
            v = S_SortH(b.Cells.Resize(LastRow, LastCol).Value, b.lines, b.sortDescending)
          Else
            v = S_Sortv(b.Cells.Resize(LastRow, LastCol).Value, b.lines, b.sortDescending)
          End If
          Works(i).Action = 2
          Works(i).Value = v(1, 1)
          b.Caller.Resize(UBound(v), UBound(v, 2)) = v
          b.Caller.Formula = b.Formula
        Else
          Works(i).Action = 3
        End If
      Else
        Works(i).Action = 3
      End If
    Case 3: k = k + 1
    End Select
n:
  Next
  If k >= ub Then
    Erase Works
  End If
  If Not a Is Nothing Then
    If su And a.ScreenUpdating <> su Then
      a.ScreenUpdating = su
    End If
    If Ac = xlCalculationAutomatic And Ac <> a.Calculation Then
      a.Calculation = Ac
    End If
    Set a = Nothing
  End If
  On Error GoTo 0
End Sub
Bạn có thể kèm thêm ví dụ được không?
 
Hôm nay tôi lại chia sẻ cho các bạn các Hàm UDF được viết bằng VBA, nhằm mục đích để sắp xếp mảng một cách tối ưu nhất.

HÀM UDF SẮP XẾP PHÂN TẦNG (ĐA CỘT)


  1. Hàm S_SortV - Hàm trả lại mảng Sắp xếp dọc, Hàm S_SortVW là hàm ghi ra mảng cho bảng tính Excel
  2. Hàm S_SortH - Hàm trả lại mảng Sắp xếp ngang, Hàm S_SortHW là hàm ghi ra mảng cho bảng tính Excel
Hàm S_SortVW và hàm S_SortHW là hai hàm tự động ghi ra mảng ra bảng tính hoàn toàn sau khi gõ hàm, giá trị vùng thay đổi thì hàm thực thi.


Mục tiêu đạt được:
  1. Sắp xếp cả mảng ngang và mảng dọc.
  2. Sắp xếp phân tầng (đa cột)
  3. Sắp xếp Tiếng Việt
  4. Tốc độ nhanh nhất.
Hướng dẫn sử dụng hàm:

Vị trí
Tham số
Kiểu
Chức năng
1
Cells
Vùng cần tổng
Nhận vùng cần sắp xếp
2
Columns / Rows
Số cột hoặc Mảng các cột
nhập thứ tự cột hoặc mảng thứ tự hoặc không nhập
3
sortDescending
Có/Không
Sắp xếp theo thứ tự giảm dần

Ví dụ viết hàm vào bảng tính (sắp xếp dọc):
1. Sắp xếp mảng A2:Z10000 với các phân tầng là tất cả cột, lớn dần
=S_SortVW(A2:Z10000, -1, FALSE)
2. Sắp xếp mảng A2:Z10000 với cột thứ 3, lớn dần
=S_SortVW(A2:Z10000, 3, FALSE)
3. Sắp xếp mảng A2:Z10000 với các phân tầng là 1, 3, 5, 7 (thứ tự cột), lớn dần
=S_SortVW(A2:Z10000, {1, 3, 5, 7}, FALSE)
4. Sắp xếp mảng A2:Z10000 với các phân tầng là 8, 3, 5, 4 (thứ tự cột), lớn dần
=S_SortVW(A2:Z10000, {8, 3, 5, 4}, FALSE)

Ví dụ sắp xếp ngang tương tự chỉ đổi Hàm

Ví dụ viết code VBA với S_SortV và S_SortH:
PHP:
Dim Arr
Arr =S_SortV([A2:Z10000], -1, FALSE)

Code hàm sắp xếp S_SortV và S_SortH:
PHP:
Option Explicit

Private Sub S_Sort_random()
  Dim rg, R, C, a
  Set rg = Sheet1.Range("C4").Resize(100, 10)
  a = rg.Value
  VBA.Randomize
  For R = 1 To UBound(a)
    For C = 1 To UBound(a, 2)
      a(R, C) = Int(VBA.Rnd * 4) + 1
    Next
  Next
  rg.Value = a


  Set rg = Sheet1.Range("AA5").Resize(4, 20)
  a = rg.Value
  For R = 1 To UBound(a)
    For C = 1 To UBound(a, 2)
      a(R, C) = Int(VBA.Rnd * 4) + 1
    Next
  Next
  rg.Value = a
End Sub

Private Sub S_SortV_test()
  Dim B, a(1 To 10, 1 To 3), I%, j%: I = 1
'  a(i, 1) = "z": a(i, 2) = 1: a(i, 3) = 1: i = i + 1
'  a(i, 1) = "z": a(i, 2) = 2: a(i, 3) = 2: i = i + 1
'  a(i, 1) = "z": a(i, 2) = 2: a(i, 3) = 4: i = i + 1
'  a(i, 1) = "z": a(i, 2) = 2: a(i, 3) = 5: i = i + 1
'  a(i, 1) = "a": a(i, 2) = 1: a(i, 3) = 1: i = i + 1
'  a(i, 1) = "a": a(i, 2) = 2: a(i, 3) = 1: i = i + 1
'  a(i, 1) = "a": a(i, 2) = 5: a(i, 3) = 1: i = i + 1
'  a(i, 1) = ChrW(272): a(i, 2) = 2: a(i, 3) = 1: i = i + 1
'  a(i, 1) = ChrW(272): a(i, 2) = 4: a(i, 3) = 1: i = i + 1
'  a(i, 1) = ChrW(272): a(i, 2) = 1: a(i, 3) = 1: i = i + 1
  B = S_Sortv(Sheet1.[B4:F203].Value)

End Sub

Function S_Sortv(ByVal SortArray, Optional ByVal Columns = -1, Optional ByVal sortDescending As Boolean)
  On Error GoTo E
  Dim data, a(), B(), x(), w(), ww(), iw&, iww&, K&, Min&, C&, R&, I&, L&, u&, z()
  Dim lb%, ub&, lb2%, ub2&, Compare As VbCompareMethod
  Dim lv%, lcol&, col&, V, lines&, fline&, nb&
  Dim t1$, t2$, t3$, t4$, it As Boolean
  data = SortArray
  GoSub I
  QuickSortZV data, a, lcol, , , Compare
  If u > L Then
    fline = lb: lines = ub: col = Columns(L + 1): GoSub L
    If iw > 0 Then
      For lv = L + 1 To u
        lcol = Columns(lv):
        If lv < u Then
          col = Columns(lv + 1)
        End If
        If iw > 0 Then
          ww = w: iw = 0: Erase w
          For iww = 1 To UBound(ww, 2)
            I = ww(1, iww)
            fline = 1
            lines = ww(2, iww)
            B = ww(3, iww)
            Compare = ww(4, iww)
            QuickSortZV data, B, lcol, , , Compare
            GoSub L
          Next
        End If
      Next
    End If
  End If
  GoSub z
Exit Function
L:
  K = 0
  For R = fline To lines
    If I > 0 Then
      nb = R + I - 1
      a(nb) = B(R)
    Else
      nb = R
    End If
    If lv < u Then
      t1 = data(a(nb), lcol)
      If K > 0 Then
        If t2 <> t1 Then
          If K > 1 And it Then
            GoSub w
          End If
          GoTo l2
        Else
          If Not it Then
            t3 = data(a(nb), col)
            If t4 <> t3 Then
              it = True
            End If
          End If
        End If
      Else
l2:     K = 0: Min = nb: t4 = data(a(nb), col): it = False
      End If
      K = K + 1: GoSub fw
      t2 = t1
    End If
  Next
  If K > 1 And it Then
    GoSub w
  End If
Return
fw:
  ReDim Preserve x(1 To K)
  x(K) = a(nb)
  If Compare = 0 Then
    V = data(a(nb), col)
    If Not IsNumeric(V) And Not IsDate(V) And V <> vbNullString Then
      Compare = 1
    End If
  End If
Return
w:
  iw = iw + 1
  ReDim Preserve w(1 To 4, 1 To iw)
  w(1, iw) = Min
  w(2, iw) = K
  w(3, iw) = x
  w(4, iw) = Compare: Compare = 0
Return
I:
  lb = LBound(data)
  ub = UBound(data)
  lb2 = LBound(data, 2)
  ub2 = UBound(data, 2)

  If IsNumeric(Columns) Then
    If Columns < lb2 Then
      ReDim z(lb2 To ub2)
      For lcol = lb2 To ub2
        z(lcol) = lcol
      Next
      Columns = z: L = lb2: u = ub2
      lcol = Columns(L)
    ElseIf Columns > ub2 Then
      S_Sortv = data
      Exit Function
    Else
      lcol = Columns
    End If
  ElseIf IsArray(Columns) Then
    L = LBound(Columns)
    u = UBound(Columns)
    lcol = Columns(L)
  Else
    Exit Function
  End If

  ReDim a(lb To ub)
  For R = lb To ub
    a(R) = R
    If Compare = 0 Then
      V = data(R, lcol)
      If Not IsNumeric(V) And Not IsDate(V) And V <> vbNullString Then
        Compare = 1
      End If
    End If
  Next
Return
z:
  ReDim z(lb To ub, lb2 To ub2)
  If sortDescending Then
    For R = lb To ub
      For C = lb2 To ub2
        z(R, C) = data(a(ub - R + 1), C)
      Next
    Next
  Else
    For R = lb To ub
      For C = lb2 To ub2
        z(R, C) = data(a(R), C)
      Next
    Next
  End If
  S_Sortv = z
Return
E: S_Sortv = data
End Function


Private Sub QuickSortZV_test()
  Debug.Print StrComp(ChrW(272), ChrW(273), 1), ChrW(272) < ChrW(273)
  Debug.Print StrComp(ChrW(272), ChrW(273), 1) = 0 And ChrW(272) < ChrW(273)
End Sub
Sub QuickSortZV( _
              ByVal SortArray As Variant, _
                    ArrayTemp(), _
            Optional ByVal lngColumn& = -1, _
            Optional lngMin& = -1, _
            Optional lngMax& = -1, _
            Optional Compare As VbCompareMethod = VbCompareMethod.vbBinaryCompare)

  On Error Resume Next
  Dim I&, j&, varMid, Temp
  Dim lngColTemp As Long
  If IsEmpty(SortArray) Then Exit Sub
  If InStr(TypeName(SortArray), "()") < 1 Then Exit Sub
  If lngMin = -1 Then lngMin = LBound(ArrayTemp, 1)
  If lngMax = -1 Then lngMax = UBound(ArrayTemp, 1)
  If lngMin >= lngMax Then Exit Sub

  I = lngMin: j = lngMax
  varMid = Empty: varMid = SortArray(ArrayTemp((lngMin + lngMax) \ 2), lngColumn)
  If IsEmpty(varMid) Then
    I = lngMax: j = lngMin
  ElseIf IsNull(varMid) Then
    I = lngMax: j = lngMin
  ElseIf varMid = vbNullString Then
    I = lngMax: j = lngMin
  ElseIf VarType(varMid) = vbError Then
    I = lngMax: j = lngMin
  ElseIf VarType(varMid) > 17 Then
    I = lngMax: j = lngMin
  End If

  If Compare = vbBinaryCompare Then
    While I <= j
      While SortArray(ArrayTemp(I), lngColumn) < varMid And I < lngMax: I = I + 1: Wend
      While varMid < SortArray(ArrayTemp(j), lngColumn) And j > lngMin: j = j - 1: Wend
      If I <= j Then
Swap1:   Temp = ArrayTemp(I): ArrayTemp(I) = ArrayTemp(j): ArrayTemp(j) = Temp
        I = I + 1: j = j - 1
      End If
    Wend
  Else
    While I <= j
      While (StrComp(SortArray(ArrayTemp(I), lngColumn), varMid, 1) = -1 Or (SortArray(ArrayTemp(I), lngColumn) > varMid) And StrComp(SortArray(ArrayTemp(I), lngColumn), varMid, 1) = 0) And I < lngMax: I = I + 1: Wend
      While (StrComp(varMid, SortArray(ArrayTemp(j), lngColumn), 1) = -1 Or (varMid > SortArray(ArrayTemp(j), lngColumn)) And StrComp(varMid, SortArray(ArrayTemp(j), lngColumn), 1) = 0) And j > lngMin: j = j - 1: Wend
      If I <= j Then
Swap2:   Temp = ArrayTemp(I): ArrayTemp(I) = ArrayTemp(j): ArrayTemp(j) = Temp
        I = I + 1: j = j - 1
      End If
    Wend
  End If
  If (lngMin < j) Then Call QuickSortZV(SortArray, ArrayTemp, lngColumn, lngMin, j, Compare)
  If (I < lngMax) Then Call QuickSortZV(SortArray, ArrayTemp, lngColumn, I, lngMax, Compare)
End Sub


Private Sub S_SortH_test()
  Dim a, I, j
  a = S_SortH(Sheet1.[O4:AH8].Value, -1, False)
End Sub

Function S_SortH(ByVal SortArray, Optional Rows = 0, Optional sortDescending As Boolean)
  On Error GoTo E
  Dim data, a(), B(), x(), w(), ww(), iw&, iww&, K&, Min&, C&, R&, I&, L&, u&, z()
  Dim lb%, ub&, lb2%, ub2&, Compare As VbCompareMethod
  Dim lv%, lrow&, row&, V, lines&, fline&, nb&
  Dim t1$, t2$, t3$, t4$, it As Boolean
  data = SortArray
  GoSub I
  QuickSortZH data, a, lrow, , , Compare
  If u > L Then
    fline = lb2: lines = ub2: row = Rows(L + 1): GoSub L
    If iw > 0 Then
      For lv = L + 1 To u
        lrow = Rows(lv):
        If lv < u Then
          row = Rows(lv + 1)
        End If
     
        If iw > 0 Then
          ww = w: iw = 0: Erase w
          For iww = 1 To UBound(ww, 2)
            I = ww(1, iww)
            fline = 1
            lines = ww(2, iww)
            B = ww(3, iww)
            Compare = ww(4, iww)
            QuickSortZH data, B, lrow, , , Compare
            GoSub L
          Next
        End If
      Next
    End If
  End If
  GoSub z
Exit Function
L:
  K = 0
  For C = fline To lines
    If I > 0 Then
      nb = C + I - 1
      a(nb) = B(C)
    Else
      nb = C
    End If
    If lv < u Then
      t1 = data(lrow, a(nb))
      If K > 0 Then
        If t2 <> t1 Then
          If K > 1 And it Then
            GoSub w
          End If
          GoTo l2
        Else
          If Not it Then
            t3 = data(row, a(nb))
            If t4 <> t3 Then
              it = True
            End If
          End If
        End If
      Else
l2:     K = 0: Min = nb: t4 = data(row, a(nb)): it = False
      End If
      K = K + 1: GoSub fw
      t2 = t1
    End If
  Next
  If K > 1 And it Then
    GoSub w
  End If
Return
fw:
  ReDim Preserve x(1 To K)
  x(K) = a(nb)
  If Compare = 0 Then
    V = data(row, a(nb))
    If Not IsNumeric(V) And Not IsDate(V) And V <> vbNullString Then
      Compare = 1
    End If
  End If
Return
w:
  iw = iw + 1
  ReDim Preserve w(1 To 4, 1 To iw)
  w(1, iw) = Min
  w(2, iw) = K
  w(3, iw) = x
  w(4, iw) = Compare: Compare = 0
Return
I:
  lb = LBound(data)
  ub = UBound(data)
  lb2 = LBound(data, 2)
  ub2 = UBound(data, 2)

  If IsNumeric(Rows) Then
    If Rows < lb Then
      ReDim z(lb To ub)
      For lrow = lb To ub
        z(lrow) = lrow
      Next
      Rows = z
      L = lb
      u = ub
      lrow = Rows(L)
    ElseIf Rows > ub Then
      S_SortH = data
      Exit Function
    Else
      lrow = Rows
    End If
  ElseIf IsArray(Rows) Then
    L = LBound(Rows)
    u = UBound(Rows)
    lrow = Rows(L)
  Else
    Exit Function
  End If

  ReDim a(lb2 To ub2)
  For C = lb2 To ub2
    a(C) = C
    If Compare = 0 Then
      V = data(lrow, C)
      If Not IsNumeric(V) And Not IsDate(V) And V <> vbNullString Then
        Compare = 1
      End If
    End If
  Next
Return
z:
  ReDim z(lb To ub, lb2 To ub2)
  If sortDescending Then
    For R = lb To ub
      For C = lb2 To ub2
        z(R, C) = data(R, a(ub - C + 1))
      Next
    Next
  Else
    For R = lb To ub
      For C = lb2 To ub2
        z(R, C) = data(R, a(C))
      Next
    Next
  End If
  S_SortH = z
Return
E: S_SortH = data
End Function

Sub QuickSortZH( _
              ByVal SortArray As Variant, _
                    ArrayTemp(), _
            Optional lngRow& = -1, _
            Optional lngMin& = -1, _
            Optional lngMax& = -1, _
            Optional Compare As VbCompareMethod = VbCompareMethod.vbBinaryCompare)

  On Error Resume Next
  Dim I&, j&, varMid, Temp
  Dim lngColTemp As Long
  If IsEmpty(SortArray) Then Exit Sub
  If InStr(TypeName(SortArray), "()") < 1 Then Exit Sub
  If lngMin = -1 Then lngMin = LBound(ArrayTemp, 1)
  If lngMax = -1 Then lngMax = UBound(ArrayTemp, 1)
  If lngMin >= lngMax Then Exit Sub

  I = lngMin: j = lngMax
  varMid = Empty: varMid = SortArray(lngRow, ArrayTemp((lngMin + lngMax) \ 2))
  If IsEmpty(varMid) Then
    I = lngMax: j = lngMin
  ElseIf IsNull(varMid) Then
    I = lngMax: j = lngMin
  ElseIf varMid = vbNullString Then
    I = lngMax: j = lngMin
  ElseIf VarType(varMid) = vbError Then
    I = lngMax: j = lngMin
  ElseIf VarType(varMid) > 17 Then
    I = lngMax: j = lngMin
  End If
  If Compare = vbBinaryCompare Then
    While I <= j
      While SortArray(lngRow, ArrayTemp(I)) < varMid And I < lngMax: I = I + 1: Wend
      While varMid < SortArray(lngRow, ArrayTemp(j)) And j > lngMin: j = j - 1: Wend
      If I <= j Then
Swap1:   Temp = ArrayTemp(I): ArrayTemp(I) = ArrayTemp(j): ArrayTemp(j) = Temp
        I = I + 1: j = j - 1
      End If
    Wend
  Else
    While I <= j
      While (StrComp(SortArray(lngRow, ArrayTemp(I)), varMid, 1) = -1 Or (SortArray(lngRow, ArrayTemp(I)) > varMid) And StrComp(SortArray(lngRow, ArrayTemp(I)), varMid, 1) = 0) And I < lngMax: I = I + 1: Wend
      While (StrComp(varMid, SortArray(lngRow, ArrayTemp(j)), 1) = -1 Or (varMid > SortArray(lngRow, ArrayTemp(j))) And StrComp(varMid, SortArray(lngRow, ArrayTemp(j)), 1) = 0) And j > lngMin: j = j - 1: Wend
      If I <= j Then
Swap2:   Temp = ArrayTemp(I): ArrayTemp(I) = ArrayTemp(j): ArrayTemp(j) = Temp
        I = I + 1: j = j - 1
      End If
    Wend
  End If
  If (lngMin < j) Then Call QuickSortZH(SortArray, ArrayTemp, lngRow, lngMin, j, Compare)
  If (I < lngMax) Then Call QuickSortZH(SortArray, ArrayTemp, lngRow, I, lngMax, Compare)
End Sub


Code UDF mảng động S_SortVW và S_SortHW:
PHP:
Option Explicit

Private Type TypeArguments
  Action As Long
  Formula As String
  Cells As Excel.Range
  Caller As Range
  sortDescending As Boolean
  lines As Variant
  Value As Variant
  sortHorizontal As Boolean
End Type

#If VBA7 Then
Option Explicit

Private Type TypeArguments
  Action As Long
  Formula As String
  Cells As Excel.Range
  Caller As Range
  sortDescending As Boolean
  lines As Variant
  Value As Variant
  sortHorizontal As Boolean
End Type

#If VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
''///////////////////////////////////////////////////////
#If VBA7 And Win64 Then
  Private gTimerID As LongPtr
#Else
  Private gTimerID As Long
#End If
''///////////////////////////////////////////////////////
Private Works() As TypeArguments



Function S_SortVW( _
             ByVal Cells As Range, _
    Optional ByVal Columns As Variant = -1, _
    Optional ByVal sortDescending As Boolean = False)
  On Error Resume Next
  If Cells.Worksheet.ProtectContents = True Then
    S_SortVW = "Protect"
    Exit Function
  End If

  Dim r As Object, k%, i%, s$, f$
  s = Cells.Address(0, 0)
  Set r = Application.Caller
  f = r.Formula
  S_SortVW = "wait..."

  k = UBound(Works)
  For i = 1 To k
    With Works(i)
      If .Formula = f Then
        Select Case .Action
        Case 2: S_SortVW = .Value: .Action = 3
          If gTimerID = 0 Then
            gTimerID = SetTimer(0&, 0&, 0, AddressOf S_QSort_finally)
          End If
          Exit Function
        Case Else:
          .sortDescending = sortDescending
          .lines = Columns
          .Action = 0: GoTo n
        End Select
        Exit For
      End If
    End With
  Next
  k = k + 1
  ReDim Preserve Works(1 To k)
  With Works(k)
    Set .Caller = r
    Set .Cells = Cells
    .Formula = f
    .sortDescending = sortDescending
    .lines = Columns
    .sortHorizontal = False
  End With
n:
  Set r = Nothing
  If gTimerID = 0 Then
    gTimerID = SetTimer(0&, 0&, 0, AddressOf S_QSort_callback)
  End If
  On Error GoTo 0
End Function



Function S_SortHW( _
             ByVal Cells As Range, _
    Optional ByVal Rows As Variant = -1, _
    Optional ByVal sortDescending As Boolean = False)


  On Error Resume Next
  If Cells.Worksheet.ProtectContents = True Then
    S_SortHW = "Protect"
    Exit Function
  End If

  Dim r As Object, k%, i%, s$, f$
  s = Cells.Address(0, 0)
  Set r = Application.Caller
  f = r.Formula

  S_SortHW = "wait..."
  k = UBound(Works)
  For i = 1 To k
    With Works(i)
      If .Formula = f Then
        Select Case .Action
        Case 2: S_SortHW = .Value: .Action = 3
          If gTimerID = 0 Then
            gTimerID = SetTimer(0&, 0&, 0, AddressOf S_QSort_finally)
          End If
          Exit Function
        Case Else:
          .sortDescending = sortDescending
          .lines = Rows
          .Action = 0: GoTo n
        End Select
        Exit For
      End If
    End With
  Next
  k = k + 1
  ReDim Preserve Works(1 To k)
  With Works(k)
    Set .Caller = r
    Set .Cells = Cells
    .Formula = f
    .sortDescending = sortDescending
    .lines = Rows
    .sortHorizontal = True
  End With
n:
  Set r = Nothing
  If gTimerID = 0 Then
    gTimerID = SetTimer(0&, 0&, 0, AddressOf S_QSort_callback)
  End If
  On Error GoTo 0
End Function


Private Sub S_QSort_finally()
  On Error Resume Next
  Call KillTimer(0&, gTimerID): gTimerID = 0
  Dim k%, u%
  u = UBound(Works)
  For k = 1 To u
    If Works(k).Action <> 3 Then
      Exit Sub
    End If
  Next
  If u > 0 Then
    Erase Works
  End If
End Sub

Private Sub S_QSort_callback()
  On Error Resume Next
  Call KillTimer(0&, gTimerID)
  gTimerID = 0
  S_QSort_working
  On Error GoTo 0
End Sub

Private Sub S_QSort_working()
  On Error Resume Next
  Dim ub As Integer, a As Object, b As TypeArguments, i&, k&, su As Boolean, Ac As Boolean, v As Variant
  ub = UBound(Works)
  Dim s$
  For i = 1 To ub
    b = Works(i)
    Select Case b.Action
    Case 0
      If b.Caller.Formula = b.Formula Then
        If a Is Nothing Then
          Set a = b.Cells.Parent.Parent.Parent
          su = a.ScreenUpdating
          Ac = a.Calculation
          If su Then a.ScreenUpdating = False
          If Ac = xlCalculationAutomatic Then a.Calculation = xlCalculationManual
        End If
        Works(i).Action = 1
        Dim LastRow&, LastCol%
        LastRow = b.Cells.Find("*", After:=b.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByRows).row - b.Cells.row + 1
        LastCol = b.Cells.Find("*", After:=b.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column - b.Cells.Column + 1
   
        If LastRow > 0 And LastCol > 0 Then
          If b.sortHorizontal Then
            v = S_SortH(b.Cells.Resize(LastRow, LastCol).Value, b.lines, b.sortDescending)
          Else
            v = S_Sortv(b.Cells.Resize(LastRow, LastCol).Value, b.lines, b.sortDescending)
          End If
          Works(i).Action = 2
          Works(i).Value = v(1, 1)
          b.Caller.Resize(UBound(v), UBound(v, 2)) = v
          b.Caller.Formula = b.Formula
        Else
          Works(i).Action = 3
        End If
      Else
        Works(i).Action = 3
      End If
    Case 3: k = k + 1
    End Select
n:
  Next
  If k >= ub Then
    Erase Works
  End If
  If Not a Is Nothing Then
    If su And a.ScreenUpdating <> su Then
      a.ScreenUpdating = su
    End If
    If Ac = xlCalculationAutomatic And Ac <> a.Calculation Then
      a.Calculation = Ac
    End If
    Set a = Nothing
  End If
  On Error GoTo 0
End Sub
Code quá hoàng tráng
Nếu thêm tùy chọn sortDescending cho từng "cấp độ" sẽ dể dùng hơn chỉ có 1 tùy chọn chung
=S_SortVW(A2:Z10000, {1, 3, 5, 7}, FALSE)
Sort trong Excel còn có thêm tùy chọn "Dữ liệu có dòng tiêu đề", thêm vào code không khó lắm
 
  1. Sắp xếp Tiếng Việt.
  2. Tốc độ nhanh nhất.

Có vẻ không được nhanh lắm. Hoặc tôi không biết cách dùng chăng.

Sắp xếp vùng M2:W1473 (Sắp xếp trong mảng thôi. Chuyện đập xuống sheet không nhất thiết, chỉ là ví dụ.)
Mã:
Sub test()
Dim Arr(), t
    t = Timer
    Arr = Sheet3.Range("M2:W1473").Value
    Arr = S_Sortv(Arr, [{3,4,8}])
    Sheet3.Range("M2:W1473").Value = Arr
    Debug.Print Timer - t
End Sub
 
Hôm nay tôi lại chia sẻ cho các bạn các Hàm UDF được viết bằng VBA, nhằm mục đích để sắp xếp mảng một cách tối ưu nhất.

HÀM UDF SẮP XẾP PHÂN TẦNG (ĐA HÀNG ĐA CỘT)


  1. Hàm S_SortV - Hàm trả lại mảng Sắp xếp dọc, Hàm S_SortVW là hàm ghi ra mảng cho bảng tính Excel
  2. Hàm S_SortH - Hàm trả lại mảng Sắp xếp ngang, Hàm S_SortHW là hàm ghi ra mảng cho bảng tính Excel
Hàm S_SortVW và hàm S_SortHW là hai hàm tự động ghi ra mảng ra bảng tính hoàn toàn sau khi gõ hàm, giá trị vùng thay đổi thì hàm thực thi.


Mục tiêu đạt được:
  1. Sắp xếp cả mảng ngang và mảng dọc.
  2. Sắp xếp phân tầng (đa cột).
  3. Sắp xếp Tiếng Việt.
  4. Tốc độ nhanh nhất.
  5. Giao diện đẹp mắt.
Hướng dẫn sử dụng hàm:

Vị trí
Tham số
Kiểu
Chức năng
1
Cells
Vùng cần tổng
Nhận vùng cần sắp xếp
2
Columns / Rows
Số cột hoặc Mảng các cột
nhập thứ tự cột hoặc mảng thứ tự hoặc không nhập
3
sortDescending
Có/Không
Sắp xếp theo thứ tự giảm dần

Ví dụ viết hàm vào bảng tính (sắp xếp dọc):
1. Sắp xếp mảng A2:Z10000 với các phân tầng là tất cả cột, lớn dần
=S_SortVW(A2:Z10000, -1, FALSE)
2. Sắp xếp mảng A2:Z10000 với cột thứ 3, lớn dần
=S_SortVW(A2:Z10000, 3, FALSE)
3. Sắp xếp mảng A2:Z10000 với các phân tầng là 1, 3, 5, 7 (thứ tự cột), lớn dần
=S_SortVW(A2:Z10000, {1, 3, 5, 7}, FALSE)
4. Sắp xếp mảng A2:Z10000 với các phân tầng là 8, 3, 5, 4 (thứ tự cột), lớn dần
=S_SortVW(A2:Z10000, {8, 3, 5, 4}, FALSE)

Ví dụ sắp xếp ngang tương tự chỉ đổi Hàm

Ví dụ viết code VBA với S_SortV và S_SortH:
PHP:
Dim Arr
Arr =S_SortV([A2:Z10000], -1, FALSE)

Các bạn sẽ thấy bên dưới có hai tập ví dụ:
  1. Tệp thực hiện sắp xếp bình thường
  2. Tệp vừa sắp xếp làm nổi bật vùng đã sắp xếp bằng cách tô màu tô màu
QuickSort Highlight Color - Excel UDF



Code hàm sắp xếp S_SortV và S_SortH:
PHP:
Option Explicit

Private Sub S_Sort_random()
  Dim rg, r, C, a
  Set rg = Sheet1.Range("C4").Resize(100, 10)
  a = rg.Value
  VBA.Randomize
  For r = 1 To UBound(a)
    For C = 1 To UBound(a, 2)
      a(r, C) = Int(VBA.Rnd * 4) + 1
    Next
  Next
  rg.Value = a


  Set rg = Sheet1.Range("AA5").Resize(4, 20)
  a = rg.Value
  For r = 1 To UBound(a)
    For C = 1 To UBound(a, 2)
      a(r, C) = Int(VBA.Rnd * 4) + 1
    Next
  Next
  rg.Value = a
End Sub


Function S_SortV(ByVal SortArray, Optional ByVal Columns = -1, Optional ByVal sortDescending As Boolean)
  On Error GoTo E
  Dim data, a(), B(), X(), w(), ww(), iw&, iww&, K&, Min&, C&, r&, I&, L&, u&, z()
  Dim lb%, ub&, lb2%, ub2&, Compare As VbCompareMethod
  Dim lv%, lcol&, col&, V, lines&, fline&, nb&
  Dim t1$, t2$, t3$, t4$, it As Boolean
  data = SortArray
  GoSub I
  QuickSortZV data, a, lcol, , , Compare
  If u > L Then
    fline = lb: lines = ub: col = Columns(L + 1): GoSub L
    If iw > 0 Then
      For lv = L + 1 To u
        lcol = Columns(lv):
        If lv < u Then
          col = Columns(lv + 1)
        End If
        If iw > 0 Then
          ww = w: iw = 0: Erase w
          For iww = 1 To UBound(ww, 2)
            I = ww(1, iww)
            fline = 1
            lines = ww(2, iww)
            B = ww(3, iww)
            If ww(5, iww) Then
              Compare = ww(4, iww)
              QuickSortZV data, B, lcol, , , Compare
            End If
            GoSub L
          Next
        End If
      Next
    End If
  End If
  GoSub z
Exit Function
L:
  K = 0
  For r = fline To lines
    If I > 0 Then
      nb = r + I - 1
      a(nb) = B(r)
    Else
      nb = r
    End If
    If lv < u Then
      t1 = data(a(nb), lcol)
      If K > 0 Then
        If t2 <> t1 Then
          GoSub w
          GoTo l2
        Else
          If Not it Then
            t3 = data(a(nb), col)
            If t4 <> t3 Then
              it = True
            End If
          End If
        End If
      Else
l2:     K = 0: Min = nb: t4 = data(a(nb), col): it = False: Compare = 0
      End If
      K = K + 1: GoSub fw
      t2 = t1
    End If
  Next
  GoSub w
Return
fw:
  ReDim Preserve X(1 To K)
  X(K) = a(nb)
  If Compare = 0 Then
    V = data(a(nb), col)
    If Not IsNumeric(V) And Not IsDate(V) And V <> vbNullString Then
      Compare = 1
    End If
  End If
Return
w:
  If K > 1 Then
    iw = iw + 1
    ReDim Preserve w(1 To 5, 1 To iw)
    w(1, iw) = Min
    w(2, iw) = K
    w(3, iw) = X
    w(4, iw) = Compare: Compare = 0
    w(5, iw) = it
  End If
Return
I:
  lb = LBound(data)
  ub = UBound(data)
  lb2 = LBound(data, 2)
  ub2 = UBound(data, 2)

  If IsNumeric(Columns) Then
    If Columns < lb2 Then
      ReDim z(lb2 To ub2)
      For lcol = lb2 To ub2
        z(lcol) = lcol
      Next
      Columns = z: L = lb2: u = ub2
      lcol = Columns(L)
    ElseIf Columns > ub2 Then
      S_SortV = data
      Exit Function
    Else
      lcol = Columns
    End If
  ElseIf IsArray(Columns) Then
    L = LBound(Columns)
    u = UBound(Columns)
    lcol = Columns(L)
  Else
    Exit Function
  End If

  ReDim a(lb To ub)
  For r = lb To ub
    a(r) = r
    If Compare = 0 Then
      V = data(r, lcol)
      If Not IsNumeric(V) And Not IsDate(V) And V <> vbNullString Then
        Compare = 1
      End If
    End If
  Next
Return
z:
  ReDim z(lb To ub, lb2 To ub2)
  If sortDescending Then
    For r = lb To ub
      For C = lb2 To ub2
        z(r, C) = data(a(ub - r + 1), C)
      Next
    Next
  Else
    For r = lb To ub
      For C = lb2 To ub2
        z(r, C) = data(a(r), C)
      Next
    Next
  End If
  S_SortV = z
Return
E: S_SortV = data
End Function


Private Sub QuickSortZV_test()
  Debug.Print StrComp(ChrW(272), ChrW(273), 1), ChrW(272) < ChrW(273)
  Debug.Print StrComp(ChrW(272), ChrW(273), 1) = 0 And ChrW(272) < ChrW(273)
End Sub
Sub QuickSortZV( _
              ByVal SortArray As Variant, _
                    ArrayTemp(), _
            Optional ByVal lngColumn& = -1, _
            Optional lngMin& = -1, _
            Optional lngMax& = -1, _
            Optional Compare As VbCompareMethod = VbCompareMethod.vbBinaryCompare)

  On Error Resume Next
  Dim I&, j&, varMid, Temp
  Dim lngColTemp As Long
  If IsEmpty(SortArray) Then Exit Sub
  If InStr(TypeName(SortArray), "()") < 1 Then Exit Sub
  If lngMin = -1 Then lngMin = LBound(ArrayTemp, 1)
  If lngMax = -1 Then lngMax = UBound(ArrayTemp, 1)
  If lngMin >= lngMax Then Exit Sub

  I = lngMin: j = lngMax
  varMid = Empty: varMid = SortArray(ArrayTemp((lngMin + lngMax) \ 2), lngColumn)
  If IsEmpty(varMid) Then
    I = lngMax: j = lngMin
  ElseIf IsNull(varMid) Then
    I = lngMax: j = lngMin
  ElseIf varMid = vbNullString Then
    I = lngMax: j = lngMin
  ElseIf VarType(varMid) = vbError Then
    I = lngMax: j = lngMin
  ElseIf VarType(varMid) > 17 Then
    I = lngMax: j = lngMin
  End If

  If Compare = vbBinaryCompare Then
    While I <= j
      While SortArray(ArrayTemp(I), lngColumn) < varMid And I < lngMax: I = I + 1: Wend
      While varMid < SortArray(ArrayTemp(j), lngColumn) And j > lngMin: j = j - 1: Wend
      If I <= j Then
Swap1:   Temp = ArrayTemp(I): ArrayTemp(I) = ArrayTemp(j): ArrayTemp(j) = Temp
        I = I + 1: j = j - 1
      End If
    Wend
  Else
    While I <= j
      While (StrComp(SortArray(ArrayTemp(I), lngColumn), varMid, 1) = -1 Or (SortArray(ArrayTemp(I), lngColumn) > varMid) And StrComp(SortArray(ArrayTemp(I), lngColumn), varMid, 1) = 0) And I < lngMax: I = I + 1: Wend
      While (StrComp(varMid, SortArray(ArrayTemp(j), lngColumn), 1) = -1 Or (varMid > SortArray(ArrayTemp(j), lngColumn)) And StrComp(varMid, SortArray(ArrayTemp(j), lngColumn), 1) = 0) And j > lngMin: j = j - 1: Wend
      If I <= j Then
Swap2:   Temp = ArrayTemp(I): ArrayTemp(I) = ArrayTemp(j): ArrayTemp(j) = Temp
        I = I + 1: j = j - 1
      End If
    Wend
  End If
  If (lngMin < j) Then Call QuickSortZV(SortArray, ArrayTemp, lngColumn, lngMin, j, Compare)
  If (I < lngMax) Then Call QuickSortZV(SortArray, ArrayTemp, lngColumn, I, lngMax, Compare)
End Sub


Private Sub S_SortH_test()
  Dim a, I, j
  a = S_SortH(Sheet1.[O4:AH8].Value, -1, False)
End Sub

Function S_SortH(ByVal SortArray, Optional Rows = 0, Optional sortDescending As Boolean)
  On Error GoTo E
  Dim data, a(), B(), X(), w(), ww(), iw&, iww&, K&, Min&, C&, r&, I&, L&, u&, z()
  Dim lb%, ub&, lb2%, ub2&, Compare As VbCompareMethod
  Dim lv%, lrow&, row&, V, lines&, fline&, nb&
  Dim t1$, t2$, t3$, t4$, it As Boolean
  data = SortArray
  GoSub I
  QuickSortZH data, a, lrow, , , Compare
  If u > L Then
    fline = lb2: lines = ub2: row = Rows(L + 1): GoSub L
    If iw > 0 Then
      For lv = L + 1 To u
        lrow = Rows(lv):
        If lv < u Then
          row = Rows(lv + 1)
        End If
      
        If iw > 0 Then
          ww = w: iw = 0: Erase w
          For iww = 1 To UBound(ww, 2)
            I = ww(1, iww)
            fline = 1
            lines = ww(2, iww)
            B = ww(3, iww)
            If ww(5, iww) Then
              Compare = ww(4, iww)
              QuickSortZH data, B, lrow, , , Compare
            End If
            GoSub L
          Next
        End If
      Next
    End If
  End If
  GoSub z
Exit Function
L:
  K = 0
  For C = fline To lines
    If I > 0 Then
      nb = C + I - 1
      a(nb) = B(C)
    Else
      nb = C
    End If
    If lv < u Then
      t1 = data(lrow, a(nb))
      If K > 0 Then
        If t2 <> t1 Then
          GoSub w
          GoTo l2
        Else
          If Not it Then
            t3 = data(row, a(nb))
            If t4 <> t3 Then
              it = True
            End If
          End If
        End If
      Else
l2:     K = 0: Min = nb: t4 = data(row, a(nb)): it = False: Compare = 0
      End If
      K = K + 1: GoSub fw
      t2 = t1
    End If
  Next
  GoSub w
Return
fw:
  ReDim Preserve X(1 To K)
  X(K) = a(nb)
  If Compare = 0 Then
    V = data(row, a(nb))
    If Not IsNumeric(V) And Not IsDate(V) And V <> vbNullString Then
      Compare = 1
    End If
  End If
Return
w:
  If K > 1 Then
    iw = iw + 1
    ReDim Preserve w(1 To 5, 1 To iw)
    w(1, iw) = Min
    w(2, iw) = K
    w(3, iw) = X
    w(4, iw) = Compare: Compare = 0
    w(5, iw) = it
  End If
Return
I:
  lb = LBound(data)
  ub = UBound(data)
  lb2 = LBound(data, 2)
  ub2 = UBound(data, 2)

  If IsNumeric(Rows) Then
    If Rows < lb Then
      ReDim z(lb To ub)
      For lrow = lb To ub
        z(lrow) = lrow
      Next
      Rows = z
      L = lb
      u = ub
      lrow = Rows(L)
    ElseIf Rows > ub Then
      S_SortH = data
      Exit Function
    Else
      lrow = Rows
    End If
  ElseIf IsArray(Rows) Then
    L = LBound(Rows)
    u = UBound(Rows)
    lrow = Rows(L)
  Else
    Exit Function
  End If

  ReDim a(lb2 To ub2)
  For C = lb2 To ub2
    a(C) = C
    If Compare = 0 Then
      V = data(lrow, C)
      If Not IsNumeric(V) And Not IsDate(V) And V <> vbNullString Then
        Compare = 1
      End If
    End If
  Next
Return
z:
  ReDim z(lb To ub, lb2 To ub2)
  If sortDescending Then
    For r = lb To ub
      For C = lb2 To ub2
        z(r, C) = data(r, a(ub2 - C + 1))
      Next
    Next
  Else
    For r = lb To ub
      For C = lb2 To ub2
        z(r, C) = data(r, a(C))
      Next
    Next
  End If
  S_SortH = z
Return
E: S_SortH = data
End Function

Sub QuickSortZH( _
              ByVal SortArray As Variant, _
                    ArrayTemp(), _
            Optional lngRow& = -1, _
            Optional lngMin& = -1, _
            Optional lngMax& = -1, _
            Optional Compare As VbCompareMethod = VbCompareMethod.vbBinaryCompare)

  On Error Resume Next
  Dim I&, j&, varMid, Temp
  Dim lngColTemp As Long
  If IsEmpty(SortArray) Then Exit Sub
  If InStr(TypeName(SortArray), "()") < 1 Then Exit Sub
  If lngMin = -1 Then lngMin = LBound(ArrayTemp, 1)
  If lngMax = -1 Then lngMax = UBound(ArrayTemp, 1)
  If lngMin >= lngMax Then Exit Sub

  I = lngMin: j = lngMax
  varMid = Empty: varMid = SortArray(lngRow, ArrayTemp((lngMin + lngMax) \ 2))
  If IsEmpty(varMid) Then
    I = lngMax: j = lngMin
  ElseIf IsNull(varMid) Then
    I = lngMax: j = lngMin
  ElseIf varMid = vbNullString Then
    I = lngMax: j = lngMin
  ElseIf VarType(varMid) = vbError Then
    I = lngMax: j = lngMin
  ElseIf VarType(varMid) > 17 Then
    I = lngMax: j = lngMin
  End If
  If Compare = vbBinaryCompare Then
    While I <= j
      While SortArray(lngRow, ArrayTemp(I)) < varMid And I < lngMax: I = I + 1: Wend
      While varMid < SortArray(lngRow, ArrayTemp(j)) And j > lngMin: j = j - 1: Wend
      If I <= j Then
Swap1:   Temp = ArrayTemp(I): ArrayTemp(I) = ArrayTemp(j): ArrayTemp(j) = Temp
        I = I + 1: j = j - 1
      End If
    Wend
  Else
    While I <= j
      While (StrComp(SortArray(lngRow, ArrayTemp(I)), varMid, 1) = -1 Or (SortArray(lngRow, ArrayTemp(I)) > varMid) And StrComp(SortArray(lngRow, ArrayTemp(I)), varMid, 1) = 0) And I < lngMax: I = I + 1: Wend
      While (StrComp(varMid, SortArray(lngRow, ArrayTemp(j)), 1) = -1 Or (varMid > SortArray(lngRow, ArrayTemp(j))) And StrComp(varMid, SortArray(lngRow, ArrayTemp(j)), 1) = 0) And j > lngMin: j = j - 1: Wend
      If I <= j Then
Swap2:   Temp = ArrayTemp(I): ArrayTemp(I) = ArrayTemp(j): ArrayTemp(j) = Temp
        I = I + 1: j = j - 1
      End If
    Wend
  End If
  If (lngMin < j) Then Call QuickSortZH(SortArray, ArrayTemp, lngRow, lngMin, j, Compare)
  If (I < lngMax) Then Call QuickSortZH(SortArray, ArrayTemp, lngRow, I, lngMax, Compare)
End Sub


Code UDF mảng động S_SortVW và S_SortHW:
PHP:
Option Explicit

Private Type TypeArguments
  Action As Long
  Formula As String
  Cells As Excel.Range
  Caller As Range
  sortDescending As Boolean
  lines As Variant
  Value As Variant
  sortHorizontal As Boolean
End Type

#If VBA7 Then
Option Explicit

Private Type TypeArguments
  Action As Long
  Formula As String
  Cells As Excel.Range
  Caller As Range
  sortDescending As Boolean
  lines As Variant
  Value As Variant
  sortHorizontal As Boolean
End Type

#If VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
''///////////////////////////////////////////////////////
#If VBA7 And Win64 Then
  Private gTimerID As LongPtr
#Else
  Private gTimerID As Long
#End If
''///////////////////////////////////////////////////////
Private Works() As TypeArguments



Function S_SortVW( _
             ByVal Cells As Range, _
    Optional ByVal Columns As Variant = -1, _
    Optional ByVal sortDescending As Boolean = False)
  On Error Resume Next
  If Cells.Worksheet.ProtectContents = True Then
    S_SortVW = "Protect"
    Exit Function
  End If

  Dim r As Object, k%, i%, s$, f$
  s = Cells.Address(0, 0)
  Set r = Application.Caller
  f = r.Formula
  S_SortVW = "wait..."

  k = UBound(Works)
  For i = 1 To k
    With Works(i)
      If .Formula = f Then
        Select Case .Action
        Case 2: S_SortVW = .Value: .Action = 3
          If gTimerID = 0 Then
            gTimerID = SetTimer(0&, 0&, 0, AddressOf S_QSort_finally)
          End If
          Exit Function
        Case Else:
          .sortDescending = sortDescending
          .lines = Columns
          .Action = 0: GoTo n
        End Select
        Exit For
      End If
    End With
  Next
  k = k + 1
  ReDim Preserve Works(1 To k)
  With Works(k)
    Set .Caller = r
    Set .Cells = Cells
    .Formula = f
    .sortDescending = sortDescending
    .lines = Columns
    .sortHorizontal = False
  End With
n:
  Set r = Nothing
  If gTimerID = 0 Then
    gTimerID = SetTimer(0&, 0&, 0, AddressOf S_QSort_callback)
  End If
  On Error GoTo 0
End Function



Function S_SortHW( _
             ByVal Cells As Range, _
    Optional ByVal Rows As Variant = -1, _
    Optional ByVal sortDescending As Boolean = False)


  On Error Resume Next
  If Cells.Worksheet.ProtectContents = True Then
    S_SortHW = "Protect"
    Exit Function
  End If

  Dim r As Object, k%, i%, s$, f$
  s = Cells.Address(0, 0)
  Set r = Application.Caller
  f = r.Formula

  S_SortHW = "wait..."
  k = UBound(Works)
  For i = 1 To k
    With Works(i)
      If .Formula = f Then
        Select Case .Action
        Case 2: S_SortHW = .Value: .Action = 3
          If gTimerID = 0 Then
            gTimerID = SetTimer(0&, 0&, 0, AddressOf S_QSort_finally)
          End If
          Exit Function
        Case Else:
          .sortDescending = sortDescending
          .lines = Rows
          .Action = 0: GoTo n
        End Select
        Exit For
      End If
    End With
  Next
  k = k + 1
  ReDim Preserve Works(1 To k)
  With Works(k)
    Set .Caller = r
    Set .Cells = Cells
    .Formula = f
    .sortDescending = sortDescending
    .lines = Rows
    .sortHorizontal = True
  End With
n:
  Set r = Nothing
  If gTimerID = 0 Then
    gTimerID = SetTimer(0&, 0&, 0, AddressOf S_QSort_callback)
  End If
  On Error GoTo 0
End Function


Private Sub S_QSort_finally()
  On Error Resume Next
  Call KillTimer(0&, gTimerID): gTimerID = 0
  Dim k%, u%
  u = UBound(Works)
  For k = 1 To u
    If Works(k).Action <> 3 Then
      Exit Sub
    End If
  Next
  If u > 0 Then
    Erase Works
  End If
End Sub

Private Sub S_QSort_callback()
  On Error Resume Next
  Call KillTimer(0&, gTimerID)
  gTimerID = 0
  S_QSort_working
  On Error GoTo 0
End Sub

Private Sub S_QSort_working()
  On Error Resume Next
  Dim ub As Integer, a As Object, b As TypeArguments, i&, k&, su As Boolean, Ac As Boolean, v As Variant
  ub = UBound(Works)
  Dim s$
  For i = 1 To ub
    b = Works(i)
    Select Case b.Action
    Case 0
      If b.Caller.Formula = b.Formula Then
        If a Is Nothing Then
          Set a = b.Cells.Parent.Parent.Parent
          su = a.ScreenUpdating
          Ac = a.Calculation
          If su Then a.ScreenUpdating = False
          If Ac = xlCalculationAutomatic Then a.Calculation = xlCalculationManual
        End If
        Works(i).Action = 1
        Dim LastRow&, LastCol%
        LastRow = b.Cells.Find("*", After:=b.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByRows).row - b.Cells.row + 1
        LastCol = b.Cells.Find("*", After:=b.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column - b.Cells.Column + 1

        If LastRow > 0 And LastCol > 0 Then
          If b.sortHorizontal Then
            v = S_SortH(b.Cells.Resize(LastRow, LastCol).Value, b.lines, b.sortDescending)
          Else
            v = S_Sortv(b.Cells.Resize(LastRow, LastCol).Value, b.lines, b.sortDescending)
          End If
          Works(i).Action = 2
          Works(i).Value = v(1, 1)
          b.Caller.Resize(UBound(v), UBound(v, 2)) = v
          b.Caller.Formula = b.Formula
        Else
          Works(i).Action = 3
        End If
      Else
        Works(i).Action = 3
      End If
    Case 3: k = k + 1
    End Select
n:
  Next
  If k >= ub Then
    Erase Works
  End If
  If Not a Is Nothing Then
    If su And a.ScreenUpdating <> su Then
      a.ScreenUpdating = su
    End If
    If Ac = xlCalculationAutomatic And Ac <> a.Calculation Then
      a.Calculation = Ac
    End If
    Set a = Nothing
  End If
  On Error GoTo 0
End Sub
Có lẽ là tốc độ xử lý còn tùy thuộc dữ liệu đầu vào & thuật toán sort áp dụng tương ứng, quick sort không phải là nhanh nhất với tất cả các loại dữ liệu
 

batman1

Bác có giải pháp nào tốt hơn không?
HeapSort , Shell Sort , Quick Sort 3 sẽ nhanh hơn Quick Sort hiện tại
Tôi cũng "chơi" hồi 2012-2013, cũng QuickSort. Làm sắp xếp tới 3 cột, mỗi cột tăng giảm riêng, unicode, VNI,TCVN3, phân biệt hoa và thường. Cũng định sửa để sắp xếp với số cột tùy ý nhưng thấy bản thân không có nhu cầu và cũng chả ai quan tâm nên thôi.
 
Cám ơn tác giả đã đưa giải pháp này, khá hay

Nhưng có thể mong tác giả giải thích việc này:

Thấy khái niệm mới: Siêu hàm
Không hiểu là liên hàm, hay hàm của trên hàm ... không hiểu thật sự về từ này

Quả thật cần xem lại từ nghữ giật title (tiêu đề) , và nội dung còn nhiều từ lạ,
Về thuật toán nhanh nhất thì phải cạnh tranh so với sắp xếp chính thống của Excel thì mới đọ nhất nhì, trước khi so với các code khác.
 
Tôi cũng "chơi" hồi 2012-2013, cũng QuickSort. Làm sắp xếp tới 3 cột, mỗi cột tăng giảm riêng, unicode, VNI,TCVN3, phân biệt hoa và thường. Cũng định sửa để sắp xếp với số cột tùy ý nhưng thấy bản thân không có nhu cầu và cũng chả ai quan tâm nên thôi.
Bạn có thể chia sẻ lại cách làm này của bạn được không?
Cảm ơn bạn.
 
*** Cập nhật: Sắp xếp thứ tự cho riêng từng cột hoặc hàng. Bằng cách nhập số âm vào các cột cần sắp xếp.
Ví dụ: Sắp xếp A1:E1000, các cột 4, 2, 3, 1, 5 theo thứ tự tăng giảm đang xen, có đầu đề
=S_SortVW(A1:E1000, {-4, 2, -3, 1, -5}, TRUE)
 
Bạn có thể chia sẻ lại cách làm này của bạn được không?
Cảm ơn bạn.
Hồi xưa tôi (siwtom) đặt các tập tin đính kèm trên mediafire. Mấy năm bỏ GPE nên tôi xóa tất cả các tập tin trên mediafire để làm gọn.

1. Hồi xưa tôi định gộp 3 đoạn code dùng để sắp xếp 3 cột để làm gọn và có thể sắp xếp với số cột tùy ý. Tuy nhiên do không có nhu cầu nên thôi không làm nữa. Bây giờ càng không có hứng. Bây giờ là nghỉ ngơi thôi.

2. Code trong 2 module. Module vietnamese_convert dùng để chuyển đổi từ encoding này sang encoding khác, và loại bỏ dấu. Module modSort2DArray dùng để sắp xếp.

3. Trong quá khứ có nhiều người bắt bẻ tôi là không hiểu 2 tham số iLo và iHi trong sub QuickSort. Nếu đọc kỹ thì sẽ thấy QuickSort là code đệ qui, nó gọi chính nó với iLo và iHi ở mỗi lần gọi khác nhau. Bản thân QuickSort và những code gọi QuickSort phải truyền vào 3 tham số chính: Arr là mảng cần sắp xếp, iLo và iHi xác định cụm dòng (TỪ ... ĐẾN ...) cần sắp xếp trong mảng Arr. Vd. Arr là mảng có 5 cột và 1000 dòng. Nếu iLo = 234, iHi = 789 thì có nghĩa là chỉ các dòng từ 234 tới 789 sẽ được sắp xếp, còn các dòng từ 1 tới 233 và từ 790 tới 1000 ở nguyên vị trí. Nếu ta muốn sắp xếp toàn bộ mảng Arr mà Arr không có dòng tiêu đề thì ta truyền iLo = LBound(Arr, 1), iHi = UBound(Arr, 1). Nếu Arr chứa dòng tiêu đề thì truyền iLo = LBound(Arr, 1)+1 (dòng 1 - dòng tiêu đề sẽ ở nguyên vị trí 1), iHi = UBound(Arr, 1).

4. Tôi không có ý định chỉnh sửa, tối ưu code. Bây giờ là thời gian nghỉ ngơi, giải trí, hưởng thụ cuộc sống thôi.
-----------------
À, kết quả sắp xếp của tôi hơi khác với HeSanBi.

Do tôi qui định:
- nếu không có dấu thanh thì a < ă < â, e < ê, o < ô < ơ, u < ư
- với dấu thanh: không có < huyền < hỏi < ngã < sắc < nặng.
 

File đính kèm

  • Ket qua thi dai hoc.xlsm
    279.6 KB · Đọc: 27
Lần chỉnh sửa cuối:
Hồi xưa tôi (siwtom) đặt các tập tin đính kèm trên mediafire. Mấy năm bỏ GPE nên tôi xóa tất cả các tập tin trên mediafire để làm gọn.

1. Hồi xưa tôi định gộp 3 đoạn code dùng để sắp xếp 3 cột để làm gọn và có thể sắp xếp với số cột tùy ý. Tuy nhiên do không có nhu cầu nên thôi không làm nữa. Bây giờ càng không có hứng. Bây giờ là nghỉ ngơi thôi.

2. Code trong 2 module. Module vietnamese_convert dùng để chuyển đổi từ encoding này sang encoding khác, và loại bỏ dấu. Module modSort2DArray dùng để sắp xếp.

3. Trong quá khứ có nhiều người bắt bẻ tôi là không hiểu 2 tham số iLo và iHi trong sub QuickSort. Nếu đọc kỹ thì sẽ thấy QuickSort là code đệ qui, nó gọi chính nó với iLo và iHi ở mỗi lần gọi khác nhau. Bản thân QuickSort và những code gọi QuickSort phải truyền vào 3 tham số chính: Arr là mảng cần sắp xếp, iLo và iHi xác định cụm dòng (TỪ ... ĐẾN ...) cần sắp xếp trong mảng Arr. Vd. Arr là mảng có 5 cột và 1000 dòng. Nếu iLo = 234, iHi = 789 thì có nghĩa là chỉ các dòng từ 234 tới 789 sẽ được sắp xếp, còn các dòng từ 1 tới 233 và từ 790 tới 1000 ở nguyên vị trí. Nếu ta muốn sắp xếp toàn bộ mảng Arr mà Arr không có dòng tiêu đề thì ta truyền iLo = LBound(Arr, 1), iHi = UBound(Arr, 1). Nếu Arr chứa dòng tiêu đề thì truyền iLo = LBound(Arr, 1)+1 (dòng 1 - dòng tiêu đề sẽ ở nguyên vị trí 1), iHi = UBound(Arr, 1).

4. Tôi không có ý định chỉnh sửa, tối ưu code. Bây giờ là thời gian nghỉ ngơi, giải trí, hưởng thụ cuộc sống thôi.
-----------------
À, kết quả sắp xếp của tôi hơi khác với HeSanBi.

Do tôi qui định:
- nếu không có dấu thanh thì a < ă < â, e < ê, o < ô < ơ, u < ư
- với dấu thanh: không có < huyền < hỏi < ngã < sắc < nặng.
Tuyệt vời tôi hỏi đúng người rồi, cảm ơn tiền bối nhiều, chúc bạn có những giấy phút thư giãn thật vui vẻ.
 
Hồi xưa tôi (siwtom) đặt các tập tin đính kèm trên mediafire. Mấy năm bỏ GPE nên tôi xóa tất cả các tập tin trên mediafire để làm gọn.

1. Hồi xưa tôi định gộp 3 đoạn code dùng để sắp xếp 3 cột để làm gọn và có thể sắp xếp với số cột tùy ý. Tuy nhiên do không có nhu cầu nên thôi không làm nữa. Bây giờ càng không có hứng. Bây giờ là nghỉ ngơi thôi.

2. Code trong 2 module. Module vietnamese_convert dùng để chuyển đổi từ encoding này sang encoding khác, và loại bỏ dấu. Module modSort2DArray dùng để sắp xếp.

3. Trong quá khứ có nhiều người bắt bẻ tôi là không hiểu 2 tham số iLo và iHi trong sub QuickSort. Nếu đọc kỹ thì sẽ thấy QuickSort là code đệ qui, nó gọi chính nó với iLo và iHi ở mỗi lần gọi khác nhau. Bản thân QuickSort và những code gọi QuickSort phải truyền vào 3 tham số chính: Arr là mảng cần sắp xếp, iLo và iHi xác định cụm dòng (TỪ ... ĐẾN ...) cần sắp xếp trong mảng Arr. Vd. Arr là mảng có 5 cột và 1000 dòng. Nếu iLo = 234, iHi = 789 thì có nghĩa là chỉ các dòng từ 234 tới 789 sẽ được sắp xếp, còn các dòng từ 1 tới 233 và từ 790 tới 1000 ở nguyên vị trí. Nếu ta muốn sắp xếp toàn bộ mảng Arr mà Arr không có dòng tiêu đề thì ta truyền iLo = LBound(Arr, 1), iHi = UBound(Arr, 1). Nếu Arr chứa dòng tiêu đề thì truyền iLo = LBound(Arr, 1)+1 (dòng 1 - dòng tiêu đề sẽ ở nguyên vị trí 1), iHi = UBound(Arr, 1).

4. Tôi không có ý định chỉnh sửa, tối ưu code. Bây giờ là thời gian nghỉ ngơi, giải trí, hưởng thụ cuộc sống thôi.
-----------------
À, kết quả sắp xếp của tôi hơi khác với HeSanBi.

Do tôi qui định:
- nếu không có dấu thanh thì a < ă < â, e < ê, o < ô < ơ, u < ư
- với dấu thanh: không có < huyền < hỏi < ngã < sắc < nặng.
Tự nhiên lại thấy cái hay hay, bác batman1 cho em hỏi làm sao gõ được tiếng việt như thế này:
1620638865011.png
 
Của tôi thì không biết là tiếng gì :
Trong option sửa thành font courier new (Vietnamese)

Bài đã được tự động gộp:

Sao máy bạn như tờ giấy trắng vậy :p , Net Frame không có, Font cũng thiếu
Nếu bạn sử dụng Add-in này thì viết và sửa Tiếng Việt trong VBA đơn giản:
 
Lần chỉnh sửa cuối:
Trong option sửa thành font courier new (Vietnamese)

Bài đã được tự động gộp:


Nếu bạn sử dụng Add-in này thì viết và sẽ Tiếng Viết trong VBA đơn giản:
Cảm ơn bạn
 
Top Bottom