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 (1 người xem)

Pi-Pikachu · 9/5/21

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)

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
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:

Sắp xếp cả mảng ngang và mảng dọc.
Sắp xếp phân tầng (đa cột)
Sắp xếp Tiếng Việt
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?

HieuCD · 9/5/21

HeSanbi đã viết:

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)

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
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:

Sắp xếp cả mảng ngang và mảng dọc.
Sắp xếp phân tầng (đa cột)
Sắp xếp Tiếng Việt
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

HeSanbi · 9/5/21

*** Cập nhật: Sắp xếp và làm nổi bật ô đã sắp xếp bằng cách tô màu
và sửa 1 lỗi ở hàm S_SortH

batman1 · 10/5/21

HeSanbi đã viết:
Sắp xếp Tiếng Việt.

Tốc độ nhanh nhất.

Có vẻ không được nhanh lắm. Hoặc tôi không biết cách dùng chăng.

Sắp xếp vùng M2:W1473 (Sắp xếp trong mảng thôi. Chuyện đập xuống sheet không nhất thiết, chỉ là ví dụ.)

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

HeSanbi · 10/5/21

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

CHAOQUAY · 10/5/21

HeSanbi đã viết:

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)

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
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:

Sắp xếp cả mảng ngang và mảng dọc.
Sắp xếp phân tầng (đa cột).
Sắp xếp Tiếng Việt.
Tốc độ nhanh nhất.
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ụ:

Tệp thực hiện sắp xếp bình thường
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

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 · 10/5/21

HeSanbi đã viết:
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 cũng "chơi" hồi 2012-2013, cũng QuickSort. Làm sắp xếp tới 3 cột, mỗi cột tăng giảm riêng, unicode, VNI,TCVN3, phân biệt hoa và thường. Cũng định sửa để sắp xếp với số cột tùy ý nhưng thấy bản thân không có nhu cầu và cũng chả ai quan tâm nên thôi.

tigertiger · 10/5/21

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.

phuongnam366377 · 10/5/21

vì ứng dụng vào thực tế quá ít ... mạnh có khi nào xài tới đâu ... mấy cái có sẳn của Ms Office cũng đủ dùng rồi

Pi-Pikachu · 10/5/21

batman1 đã viết:
Tôi cũng "chơi" hồi 2012-2013, cũng QuickSort. Làm sắp xếp tới 3 cột, mỗi cột tăng giảm riêng, unicode, VNI,TCVN3, phân biệt hoa và thường. Cũng định sửa để sắp xếp với số cột tùy ý nhưng thấy bản thân không có nhu cầu và cũng chả 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.

HeSanbi · 10/5/21

*** 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)

Ngô Hải Đăng · 10/5/21

Nếu dữ liệu vừa số vừa chữ thì không sắp xếp đúng, tiếng Việt cũng chưa đúng lắm.
TH: vừa số vừa chữ

TH: Tiếng Việt giữa D và Đ

batman1 · 10/5/21

Pi-Pikachu đã viết:
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 các tập tin đính kèm trên mediafire. Mấy năm bỏ GPE nên tôi xóa tất cả các tập tin trên mediafire để làm gọn.

1. Hồi xưa tôi định gộp 3 đoạn code dùng để sắp xếp 3 cột để làm gọn và có thể sắp xếp với số cột tùy ý. Tuy nhiên do không có nhu cầu nên thôi không làm nữa. Bây giờ càng không có hứng. Bây giờ là nghỉ ngơi thôi.

2. Code trong 2 module. Module vietnamese_convert dùng để chuyển đổi từ encoding này sang encoding khác, và loại bỏ dấu. Module modSort2DArray dùng để sắp xếp.

3. Trong quá khứ có nhiều người bắt bẻ tôi là không hiểu 2 tham số iLo và iHi trong sub QuickSort. Nếu đọc kỹ thì sẽ thấy QuickSort là code đệ qui, nó gọi chính nó với iLo và iHi ở mỗi lần gọi khác nhau. Bản thân QuickSort và những code gọi QuickSort phải truyền vào 3 tham số chính: Arr là mảng cần sắp xếp, iLo và iHi xác định cụm dòng (TỪ ... ĐẾN ...) cần sắp xếp trong mảng Arr. Vd. Arr là mảng có 5 cột và 1000 dòng. Nếu iLo = 234, iHi = 789 thì có nghĩa là chỉ các dòng từ 234 tới 789 sẽ được sắp xếp, còn các dòng từ 1 tới 233 và từ 790 tới 1000 ở nguyên vị trí. Nếu ta muốn sắp xếp toàn bộ mảng Arr mà Arr không có dòng tiêu đề thì ta truyền iLo = LBound(Arr, 1), iHi = UBound(Arr, 1). Nếu Arr chứa dòng tiêu đề thì truyền iLo = LBound(Arr, 1)+1 (dòng 1 - dòng tiêu đề sẽ ở nguyên vị trí 1), iHi = UBound(Arr, 1).

4. Tôi không có ý định chỉnh sửa, tối ưu code. Bây giờ là thời gian nghỉ ngơi, giải trí, hưởng thụ cuộc sống thôi.
-----------------
À, kết quả sắp xếp của tôi hơi khác với HeSanBi.

Do tôi qui định:
- nếu không có dấu thanh thì a < ă < â, e < ê, o < ô < ơ, u < ư
- với dấu thanh: không có < huyền < hỏi < ngã < sắc < nặng.

Pi-Pikachu · 10/5/21

batman1 đã viết:
Hồi xưa tôi (siwtom) đặt các tập tin đính kèm trên mediafire. Mấy năm bỏ GPE nên tôi xóa tất cả các tập tin trên mediafire để làm gọn.

1. Hồi xưa tôi định gộp 3 đoạn code dùng để sắp xếp 3 cột để làm gọn và có thể sắp xếp với số cột tùy ý. Tuy nhiên do không có nhu cầu nên thôi không làm nữa. Bây giờ càng không có hứng. Bây giờ là nghỉ ngơi thôi.

2. Code trong 2 module. Module vietnamese_convert dùng để chuyển đổi từ encoding này sang encoding khác, và loại bỏ dấu. Module modSort2DArray dùng để sắp xếp.

3. Trong quá khứ có nhiều người bắt bẻ tôi là không hiểu 2 tham số iLo và iHi trong sub QuickSort. Nếu đọc kỹ thì sẽ thấy QuickSort là code đệ qui, nó gọi chính nó với iLo và iHi ở mỗi lần gọi khác nhau. Bản thân QuickSort và những code gọi QuickSort phải truyền vào 3 tham số chính: Arr là mảng cần sắp xếp, iLo và iHi xác định cụm dòng (TỪ ... ĐẾN ...) cần sắp xếp trong mảng Arr. Vd. Arr là mảng có 5 cột và 1000 dòng. Nếu iLo = 234, iHi = 789 thì có nghĩa là chỉ các dòng từ 234 tới 789 sẽ được sắp xếp, còn các dòng từ 1 tới 233 và từ 790 tới 1000 ở nguyên vị trí. Nếu ta muốn sắp xếp toàn bộ mảng Arr mà Arr không có dòng tiêu đề thì ta truyền iLo = LBound(Arr, 1), iHi = UBound(Arr, 1). Nếu Arr chứa dòng tiêu đề thì truyền iLo = LBound(Arr, 1)+1 (dòng 1 - dòng tiêu đề sẽ ở nguyên vị trí 1), iHi = UBound(Arr, 1).

4. Tôi không có ý định chỉnh sửa, tối ưu code. Bây giờ là thời gian nghỉ ngơi, giải trí, hưởng thụ cuộc sống thôi.
-----------------
À, kết quả sắp xếp của tôi hơi khác với HeSanBi.

Do tôi qui định:
- nếu không có dấu thanh thì a < ă < â, e < ê, o < ô < ơ, u < ư
- với dấu thanh: không có < huyền < hỏi < ngã < 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ẻ.

Nhattanktnn · 10/5/21

batman1 đã viết:
Hồi xưa tôi (siwtom) đặt các tập tin đính kèm trên mediafire. Mấy năm bỏ GPE nên tôi xóa tất cả các tập tin trên mediafire để làm gọn.

1. Hồi xưa tôi định gộp 3 đoạn code dùng để sắp xếp 3 cột để làm gọn và có thể sắp xếp với số cột tùy ý. Tuy nhiên do không có nhu cầu nên thôi không làm nữa. Bây giờ càng không có hứng. Bây giờ là nghỉ ngơi thôi.

2. Code trong 2 module. Module vietnamese_convert dùng để chuyển đổi từ encoding này sang encoding khác, và loại bỏ dấu. Module modSort2DArray dùng để sắp xếp.

3. Trong quá khứ có nhiều người bắt bẻ tôi là không hiểu 2 tham số iLo và iHi trong sub QuickSort. Nếu đọc kỹ thì sẽ thấy QuickSort là code đệ qui, nó gọi chính nó với iLo và iHi ở mỗi lần gọi khác nhau. Bản thân QuickSort và những code gọi QuickSort phải truyền vào 3 tham số chính: Arr là mảng cần sắp xếp, iLo và iHi xác định cụm dòng (TỪ ... ĐẾN ...) cần sắp xếp trong mảng Arr. Vd. Arr là mảng có 5 cột và 1000 dòng. Nếu iLo = 234, iHi = 789 thì có nghĩa là chỉ các dòng từ 234 tới 789 sẽ được sắp xếp, còn các dòng từ 1 tới 233 và từ 790 tới 1000 ở nguyên vị trí. Nếu ta muốn sắp xếp toàn bộ mảng Arr mà Arr không có dòng tiêu đề thì ta truyền iLo = LBound(Arr, 1), iHi = UBound(Arr, 1). Nếu Arr chứa dòng tiêu đề thì truyền iLo = LBound(Arr, 1)+1 (dòng 1 - dòng tiêu đề sẽ ở nguyên vị trí 1), iHi = UBound(Arr, 1).

4. Tôi không có ý định chỉnh sửa, tối ưu code. Bây giờ là thời gian nghỉ ngơi, giải trí, hưởng thụ cuộc sống thôi.
-----------------
À, kết quả sắp xếp của tôi hơi khác với HeSanBi.

Do tôi qui định:
- nếu không có dấu thanh thì a < ă < â, e < ê, o < ô < ơ, u < ư
- với dấu thanh: không có < huyền < hỏi < ngã < 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:

Pi-Pikachu · 10/5/21

Nhattanktnn đã viết:
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:
View attachment 258356

Của tôi thì không biết là tiếng gì :

Nhattanktnn · 10/5/21

Pi-Pikachu đã viết:
Của tôi thì không biết là tiếng gì :
View attachment 258357

Sao máy bạn như tờ giấy trắng vậy

, Net Frame không có, Font cũng thiếu

HeSanbi · 10/5/21

Pi-Pikachu đã viết:
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: 10/5/21

Nhattanktnn đã viết:
Sao máy bạn như tờ giấy trắng vậy , 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:

VBA_FastCode v2.22 - Công cụ học và viết mã VBA một cách nhanh nhất (*27/10/2023)

***** CẬP NHẬT MỚI v2.2 ***** -------------------------------------------------------------------------- Add-in được chia sẻ dưới đây, đó là những gì tôi hiểu biết về VBA và đã viết ra nó. Một Add-in Tools chỉnh sửa code VBA rất đơn giản nhưng có thể giúp các bạn học VBA và viết code nhanh...

giaiphapexcel.com

Nhattanktnn · 10/5/21

HeSanbi đã viết:
Trong option sửa thành font courier new (Vietnamese)

Bài đã được tự động gộp: 10/5/21

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:

VBA_FastCode v2.22 - Công cụ học và viết mã VBA một cách nhanh nhất (*27/10/2023)

***** CẬP NHẬT MỚI v2.2 ***** -------------------------------------------------------------------------- Add-in được chia sẻ dưới đây, đó là những gì tôi hiểu biết về VBA và đã viết ra nó. Một Add-in Tools chỉnh sửa code VBA rất đơn giản nhưng có thể giúp các bạn học VBA và viết code nhanh...

giaiphapexcel.com

Cảm ơn bạn

batman1 · 10/5/21

Pi-Pikachu đã viết:
Của tôi thì không biết là tiếng gì :

Gần 9 ̣ năm trước siwtom đã viết

HeSanbi · 11/5/21

*** Cập nhật: Tăng tốc, thay đổi giải thuật sắp xếp tiếng Việt, sắp xếp số và chuỗi.
Thêm tham số sắp xếp không phân biệt Hoa thường.

batman1 · 13/5/21

HeSanbi đã viết:
*** Cập nhật: Tăng tốc, thay đổi giải thuật sắp xếp tiếng Việt, sắp xếp số và chuỗi.
Thêm tham số sắp xếp không phân biệt Hoa thường.

Code

Mã:

Sub test()
Dim Arr
    Arr = Sheet5.Range("A1:C10").Value
    Sheet5.Range("E1").Resize(10, 3).Value = S_SortV(Arr, [{1,3,2}])
End Sub

Kết quả

Tại sao 2 không nhỏ nhất? Cột C là số mà.
-------------
Dữ liệu dùng để test giống như trong Sheet5 của tập tin đính kèm ở bài 15 trong chủ đề

Function Sort mảng 2 chiều

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...

giaiphapexcel.com

HeSanbi · 14/5/21

batman1 đã viết:
Code

Mã:

Sub test() Dim Arr Arr = Sheet5.Range("A1:C10").Value Sheet5.Range("E1").Resize(10, 3).Value = S_SortV(Arr, [{1,3,2}]) End Sub

Kết quả

Tại sao 2 không nhỏ nhất? Cột C là số mà.
-------------
Dữ liệu dùng để test giống như trong Sheet5 của tập tin đính kèm ở bài 15 trong chủ đề

Function Sort mảng 2 chiều

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...

giaiphapexcel.com

Hàm CompText lỗi ở bước so sánh hai số, nhưng hai số đó vẫn ở dạng chuỗi nên lỗi. Lần này ổn cả

PHP:

Function CompText(ByVal Text1$, ByVal Text2$, Optional ByVal MatchCase As Boolean, Optional ByVal SortDescending As Boolean) As Long
  If Text1 = Text2 Then
    CompText = 0
  ElseIf Text1 = vbNullString Then
    CompText = IIf(SortDescending, -1, 1)
  ElseIf Text2 = vbNullString Then
    CompText = IIf(SortDescending, 1, -1)
  Else
    Dim n1 As Boolean, n2 As Boolean
    n1 = IsNumeric(Text1) Or IsDate(Text1)
    n2 = IsNumeric(Text2) Or IsDate(Text2)
    If (n1 And n2) Then
      If Text1 = Text2 Then
        CompText = 0
      ElseIf CDec(Text1) < CDec(Text2) Then
        CompText = -1
      Else
        CompText = 1
      End If
    ElseIf (n1 And Not n2) Then
      CompText = -1:
    ElseIf (Not n1 And n2) Then
      CompText = 1:
    Else
      Dim l1&, l2&, l&, m1$, m2$, b As Integer, i&
      l1 = Len(Text1)
      l2 = Len(Text2)
      l = IIf(l1 > l2, l2, l1)
      For i = 1 To l
        m1 = mid(Text1, i, 1)
        m2 = mid(Text2, i, 1)
        b = StrComp(m1, m2, 1)
        Select Case True
        Case b = 0
          If m1 <> m2 And Not MatchCase Then
            CompText = IIf(m1 < m2, 1, -1): Exit Function
          End If
        Case Else
          CompText = b
          Exit Function
        End Select
        If i = l Then
          If l1 < l2 Then
            CompText = -1
          ElseIf l1 = l2 Then
            CompText = 0
          Else
            CompText = 1
          End If
        End If
      Next
    End If
  End If
End Function

Pi-Pikachu · 14/5/21

batman1 đã viết:
1. Hồi xưa tôi định gộp 3 đoạn code dùng để sắp xếp 3 cột để làm gọn và có thể sắp xếp với số cột tùy ý. Tuy nhiên do không có nhu cầu nên thôi không làm nữa. Bây giờ càng không có hứng. Bây giờ là nghỉ ngơi thôi.

Bạn ơi, khi nào có thời gian bạn phát triển thêm giúp mình theo hướng này với.

HeSanbi · 14/5/21

Pi-Pikachu đã viết:
Bạn ơi, khi nào có thời gian bạn phát triển thêm giúp mình theo hướng này với.

Hàm trên tôi đã viết đầy đủ tính năng. Bạn đọc bài chính để có hướng dẫn.

batman1 · 14/5/21

HeSanbi đã viết:
Hàm CompText lỗi ở bước so sánh hai số, nhưng hai số đó vẫn ở dạng chuỗi nên lỗi. Lần này ổn cả

Tôi tải tập tin S_QSort_Color.xlsm ở bài #1 -> chạy code bên dưới và tôi nhận được kết quả "lộn tùng phèo".
Dụng ý là sắp xếp theo 3 cột theo thứ tự: cột 2 tăng, cột 1 giảm, và cột 3 tăng.

Mã:

Sub test()
Dim Arr
    Arr = Sheet5.Range("A1:C10").Value
    Sheet5.Range("E1").Resize(10, 3).Value = S_SortV(Arr, [{2,-1,3}])
End Sub

HeSanbi · 14/5/21

Cập nhật sửa lỗi khi sắp xếp thứ tự giảm dần

@batman1 Đã sửa Bác kiểm tra lại.

batman1 · 14/5/21

HeSanbi đã viết:
Cập nhật sửa lỗi khi sắp xếp thứ tự giảm dần

@batman1 Đã sửa Bác kiểm tra lại.

Có vẻ đã hết lỗi.

batman1 · 15/5/21

Pi-Pikachu đã viết:
Bạn ơi, khi nào có thời gian bạn phát triển thêm giúp mình theo hướng này với.

Thôi được, hôm nay thứ 7 mà cũng ngại ra ngoài quá nên làm giải trí. Bạn tự kiểm tra.

Pi-Pikachu · 15/5/21

batman1 đã viết:
Thôi được, hôm nay thứ 7 mà cũng ngại ra ngoài quá nên làm giải trí. Bạn tự kiểm tra.

Cảm ơn bạn nhiều, kết quả rất tuyệt, thật hữu ích cho tôi.

batman1 · 16/5/21

HeSanbi đã viết:
Cập nhật sửa lỗi khi sắp xếp thứ tự giảm dần

@batman1 Đã sửa Bác kiểm tra lại.

Khi chạy code sẽ có lỗi. Code có lỗi khi sắp xếp cột có ngày tháng (cột C)

HeSanbi · 16/5/21

batman1 đã viết:
Khi chạy code sẽ có lỗi. Code có lỗi khi sắp xếp cột có ngày tháng (cột C)

Bác sửa đoạn CDec(CDate(Text1)) < CDec(CDate(Text2))

Pi-Pikachu · 16/5/21

batman1 đã viết:
Khi chạy code sẽ có lỗi. Code có lỗi khi sắp xếp cột có ngày tháng (cột C)

View attachment 258718

Càng lúc tôi càng cảm thấy yên tâm khi sử dụng khi sử dụng file bài 30, của bạn.

batman1 · 16/5/21

Pi-Pikachu đã viết:
Càng lúc tôi càng cảm thấy yên tâm khi sử dụng khi sử dụng file bài 30, của bạn.

Khi tôi viết code thì một trong những tiêu chí của tôi là kết quả không được phụ thuộc vào dạng unicode của dữ liệu gốc. Đã có rất nhiều người kêu ca trên GPE là dữ liệu gốc của họ không chuẩn vì được lấy từ nhiều nguồn, hoặc được nhập bởi nhiều người mà mỗi người nhập theo một kiểu. Nếu anh A khi nhập dùng unicode dựng sẵn còn cô B dùng unicode tổ hợp thì chắc chắn code của HeSanbi không thể sắp xếp đúng được. Vd. dữ liệu A1:B6, sau khi sắp xếp tăng dần theo cột A có D1:E6. Rõ ràng kết quả không đúng.

HeSanbi · 16/5/21

batman1 đã viết:
Khi tôi viết code thì một trong những tiêu chí của tôi là kết quả không được phụ thuộc vào dạng unicode của dữ liệu gốc. Đã có rất nhiều người kêu ca trên GPE là dữ liệu gốc của họ không chuẩn vì được lấy từ nhiều nguồn, hoặc được nhập bởi nhiều người mà mỗi người nhập theo một kiểu. Nếu anh A khi nhập dùng unicode dựng sẵn còn cô B dùng unicode tổ hợp thì chắc chắn code của HeSanbi không thể sắp xếp đúng được. Vd. dữ liệu A1:B6, sau khi sắp xếp tăng dần theo cột A có D1:E6. Rõ ràng kết quả không đúng.

View attachment 258742

Bác nói như vậy khác nào code của bác, A nhập unicode, B nhập VPS, cũng lỗi vậy. Muốn thì ta chuyển hết về Unicode quá đơn giản vậy mà, có gì căng

batman1 · 16/5/21

HeSanbi đã viết:
Bác nói như vậy khác nào code của bác, A nhập unicode, B nhập VPS, cũng lỗi vậy.

Tôi không nói suông. Khi tôi chỉ ra chỗ sai thì tôi cũng đính kèm tập tin đàng hoàng. Nếu bạn cho là với dữ liệu gốc có cả unicode tổ hợp và dựng sẵn thì code của tôi cũng sai thì xin mời đính kèm tập tin. Nếu bạn chưa kiểm tra code của tôi thì đừng viết: "Bác nói như vậy khác nào code của bác, A nhập unicode, B nhập VPS, cũng lỗi vậy". Nếu bạn đã kiểm tra và cho rằng code của tôi sai thì hãy đính kèm tập tin để tôi xem.

Muốn thì ta chuyển hết về Unicode quá đơn giản vậy mà, có gì căng

Căng ở chỗ là bạn không nói, và người dùng code của bạn không ý thức được những chỗ có thể có "bẫy". Bạn phải nói rõ ra để những người dùng code của bạn biết để họ chuyển hết về unicode dựng sẵn trước khi chạy code của bạn. Bạn không nói thì người ta không chuyển và kết quả sai. Nếu có 6 dòng như tôi đính kèm thì người ta sẽ nhận ra ngay, chứ nếu có hàng ngàn dòng thì họ làm sao biết?

Tôi tin là code của tôi xử lý dữ liệu lẫn lộn cả unicode dựng sẵn và unicode tổ hợp. Xử lý để sắp xếp nhưng KHÔNG THAY ĐỔI DỮ LIỆU GỐC. Tức sắp xếp vẫn đúng mà dữ liệu gốc có dựng sẵn và tổ hợp thì mãi mãi, muôn đời, vĩnh viễn nó vẫn có dựng sẵn và tổ hợp, vì code của tôi không chuyển chúng. Code của tôi không chỉnh sửa DỮ LIỆU GỐC của người dùng.

Nói A nhập unicode dựng sẵn còn B nhập unicode tổ hợp là có lý bởi thực tế đã có vậy. Nhiều người còn hỏi GPE là sao 2 đoạn text nhìn như nhau mà chúng không bằng nhau, hàm Excel không tìm thấy. Nói A nhập unicode còn B nhập VPS là nói cùn rồi.

Mà thôi, nói nhiều làm gì. Code của tôi xử lý tốt khi dữ liệu nguồn có cả unicode dựng sẵn và unicode tổ hợp. Code của bạn không xử lý được khi dữ liệu nguồn có cả unicode dựng sẵn và unicode tổ hợp. Nói rõ thế để người dùng tiềm năng khỏi bị bất ngờ.

ongke0711 · 16/5/21

Pi-Pikachu đã viết:
Càng lúc tôi càng cảm thấy yên tâm khi sử dụng khi sử dụng file bài 30, của bạn.

Nói vậy không hay rồi.
Các bạn post bài trả lời nhớ chú ý code phải chuẩn 100%, không sai mọi trường hợp, đáp ứng đúng yêu cầu chủ thớt chứ không phải chỗ thảo luận code, chỗ để trao đổi sai sửa , hoc hỏi nhé.

Pi-Pikachu · 16/5/21

ongke0711 đã viết:
Nói vậy không hay rồi.
Các bạn post bài trả lời nhớ chú ý code phải chuẩn 100%, không sai mọi trường hợp, đáp ứng đúng yêu cầu chủ thớt chứ không phải chỗ thảo luận code, chỗ để trao đổi sai sửa , hoc hỏi nhé.

Tôi nói tôi yên tâm là vì người viết đã chỉ ra các vấn đề lỗi có thể sảy ra.. đó là tôi thôi còn người khác nói hay hoặc không hay cũng được tôi không bận tâm, nhu cầu của tôi sort mảng thì chỉ cần tốc độ và các lựa chọn cột và kiểu chứ còn các tính năng khác màu tôi không dùng đến.

ongke0711 · 16/5/21

Pi-Pikachu đã viết:
Tôi nói tôi yên tâm là vì người viết đã chỉ ra các vấn đề lỗi có thể sảy ra.. đó là tôi thôi còn người khác tôi biết hay hay không hay cũng được, nhu cầu của tôi sort mảng thì chỉ cần tốc độ và các lựa chọn cột và kiểu chứ còn các tính năng khác màu tôi không dùng đến.

Càng trả lời càng tầm bậy,
Microsoft chỉ nên xây dựng hàm SUM, phát triển SUMIF làm gì, tôi chả cần, phát triển chi để Excel thêm nặng nề, các hàm lung tumg, "tôi" chả bao giờ xài tới. Người khác có xài hay không, tôi không quan tâm. Nếu không đúng yêu cầu của tôi, tôi coi nó là rác thôi. Bởi vậy nhắc nhở là các bạn trả lời đừng vung vãi chất xám lung tung nhé.

Thôi ngưng vậy.

Pi-Pikachu · 21/5/21

batman1 đã viết:
Thôi được, hôm nay thứ 7 mà cũng ngại ra ngoài quá nên làm giải trí. Bạn tự kiểm tra.

Xin chào bạn, vẫn dữ liệu trong file bạn gửi kèm tôi thử như sau:

Mã:

Sub Button3_Click()
Dim Arr, test, i, j, k
    test = Sheet5.Range("A1:C10").Value
    ReDim Arr(1 To UBound(test, 1), 1 To UBound(test, 2))
    For i = 1 To UBound(test, 1)
        If test(i, 3) < 20 Then
            k = k + 1
            For j = 1 To UBound(test, 2)
                Arr(k, j) = test(i, j)
            Next j
        End If
    Next i
    Sheet5.Range("E1").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Sort2DArray(Arr, 1, True, cc_uni, False, 2, True, cc_uni, False, 3, True, cc_nothing, False)
End Sub

Thì càng dòng không có dữ liệu sẽ sắp xếp lên trên, bạn có thể sửa giúp tôi nếu sắp xếp A đến Z điều kiện True trong với cột nào thì dữ liệu trống trong cột đó đưa xuống dưới được không?

Maika8008 · 21/5/21

Thực tình nếu so với sort của Excel thì code của ai cũng không giống được.

batman1 · 22/5/21

Pi-Pikachu đã viết:
Xin chào bạn, vẫn dữ liệu trong file bạn gửi kèm tôi thử như sau:
...
Thì càng dòng không có dữ liệu sẽ sắp xếp lên trên, bạn có thể sửa giúp tôi nếu sắp xếp A đến Z điều kiện True trong với cột nào thì dữ liệu trống trong cột đó đưa xuống dưới được không?

Tôi viết đã 8-9 năm rồi. Bây giờ mà ngồi sửa thì tôi không có hứng, mà rất có thể sẽ phải sửa nhiều.

Nhưng nếu có những dòng hoàn toàn trống ở dưới cùng, tức các phần tử của mỗi dòng đó đều rỗng, thì có thể sửa code để không sắp xếp các dòng đó. Trong trường hợp này không cần sửa nhiều.

Bạn tự kiểm tra lại hàm Sort2DArray.

Mã:

Function Sort2DArray(ByVal Arr, ByVal fromRow As Long, ByVal toRow As Long, ParamArray Args())
'    Arr là mảng cần sắp xếp
'    chỉ các dòng từ fromRow đến toRow tham gia sắp xếp, các dòng còn lại ở nguyên vị trí.
'    Args: các tham số dùng để sắp xếp. Mỗi cột cần sắp xếp được mô tả bằng 4 tham số: <cột cần sắp xếp> (long), <sắp xếp từ A đến Z> (boolean), <mã hóa cột> (convert_col), <phân biệt chữ hoa chữ thường> (boolean)
'    vd. sắp xếp theo cột 4, 2 và 8. Cột 2 và 4 dùng cc_uni, sắp xếp tăng dần, cột 8 dùng cc_nothing và sắp xếp giảm ần. Cả 3 cột không phân biệt chữ hoa chữ thường thì tham số Args là:
'    Args = 4, True, cc_uni, False, 2, True, cc_uni, False, 8, False, cc_nothing, False
'    Mảng trả về bởi Sort2DArray đã được sắp xếp
'   Ta mã hóa các cột có các ký tự tiếng Việt. Nếu cột sắp xếp có ký tự unicode (dựng sẵn hoặc tổ hợp), VNI hay TCVN3 thí ta truyền tham số convert là
'    cc_uni, cc_vni hoặc cc_vn3. Nếu cột sắp xếp không có chứa các ký tự Việt thì truyền cc_nothing.
'    Nếu không phân biệt chữ hoa thường trong khi sắp xếp thì truyền FALSE, nếu phân biệt thì truyền TRUE
Dim first As Long, last As Long, i As Long, j As Long, c As Long, index As Long, UBoundtmpArr1 As Long
Dim tmpArr, arr_index() As Long, SortCols() As Long, SortRanges
    tmpArr = Arr
    If UBound(Args) - LBound(Args) + 1 = 0 Then GoTo end_
   
    On Error GoTo error_
   
    ReDim SortCols(1 To (UBound(Args) - LBound(Args) + 1) \ 4)
    For i = 1 To UBound(SortCols)
        SortCols(i) = Args((i - 1) * 4)
    Next i
    UBoundtmpArr1 = UBound(tmpArr, 1)
    ReDim arr_index(LBound(tmpArr) To UBoundtmpArr1)
    For index = LBound(tmpArr) To UBoundtmpArr1
        arr_index(index) = index
    Next index
    If Args(2) > cc_nothing Then
        For index = LBound(tmpArr) To UBoundtmpArr1
            tmpArr(index, Args(0)) = ma_hoa_chuoi(tmpArr(index, Args(0)), Args(2), Args(3))
        Next index
    End If
    first = fromRow     '   LBound(tmpArr)
    last = toRow        'UBoundtmpArr1
    QuickSort tmpArr, arr_index, first, last, SortCols, 1, Args(1)
   
    ReDim SortRanges(1 To 2, 1 To 1)
    SortRanges(1, 1) = fromRow      '   LBound(tmpArr, 1)
    SortRanges(2, 1) = toRow        '   UBoundtmpArr1
    SortRanges = CreateSortRanges(tmpArr, SortRanges, SortCols(1))
    If Not IsEmpty(SortRanges) Then
        For i = 2 To UBound(SortCols)
            For c = 1 To UBound(SortRanges, 2)
                If Args((i - 1) * 4 + 2) > cc_nothing Then
                    For index = LBound(tmpArr) To UBoundtmpArr1
                        tmpArr(index, Args((i - 1) * 4)) = ma_hoa_chuoi(tmpArr(index, Args((i - 1) * 4)), Args((i - 1) * 4 + 2), Args((i - 1) * 4 + 3))
                    Next index
                End If
                first = SortRanges(1, c)
                last = SortRanges(2, c)
                QuickSort tmpArr, arr_index, first, last, SortCols, i, Args((i - 1) * 4 + 1)
            Next c
            If i < UBound(SortCols) Then
                SortRanges = CreateSortRanges(tmpArr, SortRanges, SortCols(i))
                If IsEmpty(SortRanges) Then Exit For
            End If
        Next i
    End If
   
    For i = LBound(tmpArr) To UBoundtmpArr1
        For j = LBound(tmpArr, 2) To UBound(tmpArr, 2)
            tmpArr(i, j) = Arr(arr_index(i), j)
        Next j
    Next i
end_:
    Sort2DArray = tmpArr
    Exit Function
error_:
End Function

Các thay đổi so với phiên bản cũ:.
1. Thêm 2 tham số fromRow và toRow.
Nếu mảng có chứa tiêu đề thì để dòng tiêu đề không tham gia sắp xếp cần truyền fromRow = 2, toRow = UBound(Arr, 1).
2. Sửa 2 dòng nằm trước dòng QuickSort tmpArr, arr_index, first, last, SortCols, 1, Args(1)
3. Sửa 2 dòng nằm trước dòng SortRanges = CreateSortRanges(tmpArr, SortRanges, SortCols(1))
----------

Mã:

Sub Button3_Click()
Dim Arr, test, i, j, k
    test = Sheet5.Range("A1:C10").Value
    ReDim Arr(1 To UBound(test, 1), 1 To UBound(test, 2))
    For i = 1 To UBound(test, 1)
        If test(i, 3) < 20 Then
            k = k + 1
            For j = 1 To UBound(test, 2)
                Arr(k, j) = test(i, j)
            Next j
        End If
    Next i
    Sheet5.Range("E1").Resize(k, UBound(Arr, 2)).Value = Sort2DArray(Arr, 1, k, 1, True, cc_uni, False, 2, True, cc_uni, False, 3, True, cc_nothing, False)
End Sub

Pi-Pikachu · 22/5/21

batman1 đã viết:

Tôi viết đã 8-9 năm rồi. Bây giờ mà ngồi sửa thì tôi không có hứng, mà rất có thể sẽ phải sửa nhiều.

Nhưng nếu có những dòng hoàn toàn trống ở dưới cùng, tức các phần tử của mỗi dòng đó đều rỗng, thì có thể sửa code để không sắp xếp các dòng đó. Trong trường hợp này không cần sửa nhiều.

Bạn tự kiểm tra lại hàm Sort2DArray.

Mã:

Function Sort2DArray(ByVal Arr, ByVal fromRow As Long, ByVal toRow As Long, ParamArray Args())
'    Arr là mảng cần sắp xếp
'    chỉ các dòng từ fromRow đến toRow tham gia sắp xếp, các dòng còn lại ở nguyên vị trí.
'    Args: các tham số dùng để sắp xếp. Mỗi cột cần sắp xếp được mô tả bằng 4 tham số: <cột cần sắp xếp> (long), <sắp xếp từ A đến Z> (boolean), <mã hóa cột> (convert_col), <phân biệt chữ hoa chữ thường> (boolean)
'    vd. sắp xếp theo cột 4, 2 và 8. Cột 2 và 4 dùng cc_uni, sắp xếp tăng dần, cột 8 dùng cc_nothing và sắp xếp giảm ần. Cả 3 cột không phân biệt chữ hoa chữ thường thì tham số Args là:
'    Args = 4, True, cc_uni, False, 2, True, cc_uni, False, 8, False, cc_nothing, False
'    Mảng trả về bởi Sort2DArray đã được sắp xếp
'   Ta mã hóa các cột có các ký tự tiếng Việt. Nếu cột sắp xếp có ký tự unicode (dựng sẵn hoặc tổ hợp), VNI hay TCVN3 thí ta truyền tham số convert là
'    cc_uni, cc_vni hoặc cc_vn3. Nếu cột sắp xếp không có chứa các ký tự Việt thì truyền cc_nothing.
'    Nếu không phân biệt chữ hoa thường trong khi sắp xếp thì truyền FALSE, nếu phân biệt thì truyền TRUE
Dim first As Long, last As Long, i As Long, j As Long, c As Long, index As Long, UBoundtmpArr1 As Long
Dim tmpArr, arr_index() As Long, SortCols() As Long, SortRanges
    tmpArr = Arr
    If UBound(Args) - LBound(Args) + 1 = 0 Then GoTo end_
  
    On Error GoTo error_
  
    ReDim SortCols(1 To (UBound(Args) - LBound(Args) + 1) \ 4)
    For i = 1 To UBound(SortCols)
        SortCols(i) = Args((i - 1) * 4)
    Next i
    UBoundtmpArr1 = UBound(tmpArr, 1)
    ReDim arr_index(LBound(tmpArr) To UBoundtmpArr1)
    For index = LBound(tmpArr) To UBoundtmpArr1
        arr_index(index) = index
    Next index
    If Args(2) > cc_nothing Then
        For index = LBound(tmpArr) To UBoundtmpArr1
            tmpArr(index, Args(0)) = ma_hoa_chuoi(tmpArr(index, Args(0)), Args(2), Args(3))
        Next index
    End If
    first = fromRow     '   LBound(tmpArr)
    last = toRow        'UBoundtmpArr1
    QuickSort tmpArr, arr_index, first, last, SortCols, 1, Args(1)
  
    ReDim SortRanges(1 To 2, 1 To 1)
    SortRanges(1, 1) = fromRow      '   LBound(tmpArr, 1)
    SortRanges(2, 1) = toRow        '   UBoundtmpArr1
    SortRanges = CreateSortRanges(tmpArr, SortRanges, SortCols(1))
    If Not IsEmpty(SortRanges) Then
        For i = 2 To UBound(SortCols)
            For c = 1 To UBound(SortRanges, 2)
                If Args((i - 1) * 4 + 2) > cc_nothing Then
                    For index = LBound(tmpArr) To UBoundtmpArr1
                        tmpArr(index, Args((i - 1) * 4)) = ma_hoa_chuoi(tmpArr(index, Args((i - 1) * 4)), Args((i - 1) * 4 + 2), Args((i - 1) * 4 + 3))
                    Next index
                End If
                first = SortRanges(1, c)
                last = SortRanges(2, c)
                QuickSort tmpArr, arr_index, first, last, SortCols, i, Args((i - 1) * 4 + 1)
            Next c
            If i < UBound(SortCols) Then
                SortRanges = CreateSortRanges(tmpArr, SortRanges, SortCols(i))
                If IsEmpty(SortRanges) Then Exit For
            End If
        Next i
    End If
  
    For i = LBound(tmpArr) To UBoundtmpArr1
        For j = LBound(tmpArr, 2) To UBound(tmpArr, 2)
            tmpArr(i, j) = Arr(arr_index(i), j)
        Next j
    Next i
end_:
    Sort2DArray = tmpArr
    Exit Function
error_:
End Function

Các thay đổi so với phiên bản cũ:.
1. Thêm 2 tham số fromRow và toRow.
Nếu mảng có chứa tiêu đề thì để dòng tiêu đề không tham gia sắp xếp cần truyền fromRow = 2, toRow = UBound(Arr, 1).
2. Sửa 2 dòng nằm trước dòng QuickSort tmpArr, arr_index, first, last, SortCols, 1, Args(1)
3. Sửa 2 dòng nằm trước dòng SortRanges = CreateSortRanges(tmpArr, SortRanges, SortCols(1))
----------

Mã:

Sub Button3_Click()
Dim Arr, test, i, j, k
    test = Sheet5.Range("A1:C10").Value
    ReDim Arr(1 To UBound(test, 1), 1 To UBound(test, 2))
    For i = 1 To UBound(test, 1)
        If test(i, 3) < 20 Then
            k = k + 1
            For j = 1 To UBound(test, 2)
                Arr(k, j) = test(i, j)
            Next j
        End If
    Next i
    Sheet5.Range("E1").Resize(k, UBound(Arr, 2)).Value = Sort2DArray(Arr, 1, k, 1, True, cc_uni, False, 2, True, cc_uni, False, 3, True, cc_nothing, False)
End Sub

Cảm ơn bạn rất nhiều.

Pi-Pikachu · 24/5/21

batman1 đã viết:

Tôi viết đã 8-9 năm rồi. Bây giờ mà ngồi sửa thì tôi không có hứng, mà rất có thể sẽ phải sửa nhiều.

Nhưng nếu có những dòng hoàn toàn trống ở dưới cùng, tức các phần tử của mỗi dòng đó đều rỗng, thì có thể sửa code để không sắp xếp các dòng đó. Trong trường hợp này không cần sửa nhiều.

Bạn tự kiểm tra lại hàm Sort2DArray.

Mã:

Function Sort2DArray(ByVal Arr, ByVal fromRow As Long, ByVal toRow As Long, ParamArray Args())
'    Arr là mảng cần sắp xếp
'    chỉ các dòng từ fromRow đến toRow tham gia sắp xếp, các dòng còn lại ở nguyên vị trí.
'    Args: các tham số dùng để sắp xếp. Mỗi cột cần sắp xếp được mô tả bằng 4 tham số: <cột cần sắp xếp> (long), <sắp xếp từ A đến Z> (boolean), <mã hóa cột> (convert_col), <phân biệt chữ hoa chữ thường> (boolean)
'    vd. sắp xếp theo cột 4, 2 và 8. Cột 2 và 4 dùng cc_uni, sắp xếp tăng dần, cột 8 dùng cc_nothing và sắp xếp giảm ần. Cả 3 cột không phân biệt chữ hoa chữ thường thì tham số Args là:
'    Args = 4, True, cc_uni, False, 2, True, cc_uni, False, 8, False, cc_nothing, False
'    Mảng trả về bởi Sort2DArray đã được sắp xếp
'   Ta mã hóa các cột có các ký tự tiếng Việt. Nếu cột sắp xếp có ký tự unicode (dựng sẵn hoặc tổ hợp), VNI hay TCVN3 thí ta truyền tham số convert là
'    cc_uni, cc_vni hoặc cc_vn3. Nếu cột sắp xếp không có chứa các ký tự Việt thì truyền cc_nothing.
'    Nếu không phân biệt chữ hoa thường trong khi sắp xếp thì truyền FALSE, nếu phân biệt thì truyền TRUE
Dim first As Long, last As Long, i As Long, j As Long, c As Long, index As Long, UBoundtmpArr1 As Long
Dim tmpArr, arr_index() As Long, SortCols() As Long, SortRanges
    tmpArr = Arr
    If UBound(Args) - LBound(Args) + 1 = 0 Then GoTo end_
  
    On Error GoTo error_
  
    ReDim SortCols(1 To (UBound(Args) - LBound(Args) + 1) \ 4)
    For i = 1 To UBound(SortCols)
        SortCols(i) = Args((i - 1) * 4)
    Next i
    UBoundtmpArr1 = UBound(tmpArr, 1)
    ReDim arr_index(LBound(tmpArr) To UBoundtmpArr1)
    For index = LBound(tmpArr) To UBoundtmpArr1
        arr_index(index) = index
    Next index
    If Args(2) > cc_nothing Then
        For index = LBound(tmpArr) To UBoundtmpArr1
            tmpArr(index, Args(0)) = ma_hoa_chuoi(tmpArr(index, Args(0)), Args(2), Args(3))
        Next index
    End If
    first = fromRow     '   LBound(tmpArr)
    last = toRow        'UBoundtmpArr1
    QuickSort tmpArr, arr_index, first, last, SortCols, 1, Args(1)
  
    ReDim SortRanges(1 To 2, 1 To 1)
    SortRanges(1, 1) = fromRow      '   LBound(tmpArr, 1)
    SortRanges(2, 1) = toRow        '   UBoundtmpArr1
    SortRanges = CreateSortRanges(tmpArr, SortRanges, SortCols(1))
    If Not IsEmpty(SortRanges) Then
        For i = 2 To UBound(SortCols)
            For c = 1 To UBound(SortRanges, 2)
                If Args((i - 1) * 4 + 2) > cc_nothing Then
                    For index = LBound(tmpArr) To UBoundtmpArr1
                        tmpArr(index, Args((i - 1) * 4)) = ma_hoa_chuoi(tmpArr(index, Args((i - 1) * 4)), Args((i - 1) * 4 + 2), Args((i - 1) * 4 + 3))
                    Next index
                End If
                first = SortRanges(1, c)
                last = SortRanges(2, c)
                QuickSort tmpArr, arr_index, first, last, SortCols, i, Args((i - 1) * 4 + 1)
            Next c
            If i < UBound(SortCols) Then
                SortRanges = CreateSortRanges(tmpArr, SortRanges, SortCols(i))
                If IsEmpty(SortRanges) Then Exit For
            End If
        Next i
    End If
  
    For i = LBound(tmpArr) To UBoundtmpArr1
        For j = LBound(tmpArr, 2) To UBound(tmpArr, 2)
            tmpArr(i, j) = Arr(arr_index(i), j)
        Next j
    Next i
end_:
    Sort2DArray = tmpArr
    Exit Function
error_:
End Function

Các thay đổi so với phiên bản cũ:.
1. Thêm 2 tham số fromRow và toRow.
Nếu mảng có chứa tiêu đề thì để dòng tiêu đề không tham gia sắp xếp cần truyền fromRow = 2, toRow = UBound(Arr, 1).
2. Sửa 2 dòng nằm trước dòng QuickSort tmpArr, arr_index, first, last, SortCols, 1, Args(1)
3. Sửa 2 dòng nằm trước dòng SortRanges = CreateSortRanges(tmpArr, SortRanges, SortCols(1))
----------

Mã:

Sub Button3_Click()
Dim Arr, test, i, j, k
    test = Sheet5.Range("A1:C10").Value
    ReDim Arr(1 To UBound(test, 1), 1 To UBound(test, 2))
    For i = 1 To UBound(test, 1)
        If test(i, 3) < 20 Then
            k = k + 1
            For j = 1 To UBound(test, 2)
                Arr(k, j) = test(i, j)
            Next j
        End If
    Next i
    Sheet5.Range("E1").Resize(k, UBound(Arr, 2)).Value = Sort2DArray(Arr, 1, k, 1, True, cc_uni, False, 2, True, cc_uni, False, 3, True, cc_nothing, False)
End Sub

Chào bạn,
Bạn có thể xử lý thêm giúp tôi truyền thêm 2 dữ liệu fromCol, toCol được không?
Ví dụ mảng truyền vào có tất 10 cột nhưng chỉ sắp xếp cột từ cột 1 đến cột 8 thôi , còn lại cột 9 và cột 10 bỏ. giống như fromRow và toRow vậy.
Cảm ơn bạn nhiều.

batman1 · 24/5/21

Pi-Pikachu đã viết:
Chào bạn,
Bạn có thể xử lý thêm giúp tôi truyền thêm 2 dữ liệu fromCol, toCol được không?
Ví dụ mảng truyền vào có tất 10 cột nhưng chỉ sắp xếp cột từ cột 1 đến cột 8 thôi , còn lại cột 9 và cột 10 bỏ. giống như fromRow và toRow vậy.
Cảm ơn bạn nhiều.

Tôi không làm nữa đâu. Tôi đã nói ngay từ đầu là tôi không muốn sửa hay tối ưu gì. Mà tôi đã làm thêm khoản sắp xếp với số cột tùy ý và fromRow, toRow.

Nếu bạn có thời gian và muốn thử sức thì tôi cho vài gợi ý. Có thể tôi chưa suy nghĩ thấu đáo nhưng bạn tự thử nghiệm.

1. Thêm fromCol và toCol.

2. Tự bạn phải phục vụ trường hợp người dùng truyền tham số Args không chuẩn. Tức Args chứa các cột cần sắp xếp mà một hoặc tất cả các cột đó lại trùng với các cột cần bỏ (từ đầu tới fromCol-1, và từ toCol+1 tới cuối).Bạn có thể nhớ nhưng người dùng code của bạn có thể không biết hoặc sơ ý. Phải phục vụ tình huống lỗi. Tức các cột từ Args phải >= fromCol và đồng thời <= toCol.

3. Thử thay ở gần cuối sub Sort2DArray

Mã:

For i = LBound(tmpArr) To UBoundtmpArr1
    For j = LBound(tmpArr, 2) To UBound(tmpArr, 2)
        tmpArr(i, j) = Arr(arr_index(i), j)
    Next j
Next i

bằng

Mã:

For i = LBound(tmpArr) To UBoundtmpArr1
    For j = fromCol To toCol
        tmpArr(i, j) = Arr(arr_index(i), j)
    Next j
Next i

Tôi sẽ không làm hộ bạn đâu.

Pi-Pikachu · 24/5/21

batman1 đã viết:
Tôi không làm nữa đâu. Tôi đã nói ngay từ đầu là tôi không muốn sửa hay tối ưu gì. Mà tôi đã làm thêm khoản sắp xếp với số cột tùy ý và fromRow, toRow.

Nếu bạn có thời gian và muốn thử sức thì tôi cho vài gợi ý. Có thể tôi chưa suy nghĩ thấu đáo nhưng bạn tự thử nghiệm.

1. Thêm fromCol và toCol.

2. Tự bạn phải phục vụ trường hợp người dùng truyền tham số Args không chuẩn. Tức Args chứa các cột cần sắp xếp mà một hoặc tất cả các cột đó lại trùng với các cột cần bỏ (từ đầu tới fromCol-1, và từ toCol+1 tới cuối).Bạn có thể nhớ nhưng người dùng code của bạn có thể không biết hoặc sơ ý. Phải phục vụ tình huống lỗi. Tức các cột từ Args phải >= fromCol và đồng thời <= toCol.

3. Thử thay ở gần cuối sub Sort2DArray

Mã:

For i = LBound(tmpArr) To UBoundtmpArr1 For j = LBound(tmpArr, 2) To UBound(tmpArr, 2) tmpArr(i, j) = Arr(arr_index(i), j) Next j Next i

bằng

Mã:

For i = LBound(tmpArr) To UBoundtmpArr1 For j = fromCol To toCol tmpArr(i, j) = Arr(arr_index(i), j) Next j Next i

Tôi sẽ không làm hộ bạn đâu.

Cảm ơn bạn nhiều.

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 (1 người xem)

Người dùng đang xem chủ đề này

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.​

File đính kèm

batman1​

batman1​

File đính kèm

​

​

@batman1 Đã sửa Bác kiểm tra lại.​

@batman1 Đã sửa Bác kiểm tra lại.​

File đính kèm

@batman1 Đã sửa Bác kiểm tra lại.​

File đính kèm

File đính kèm

Thời gian đếm ngược.

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.

batman1

batman1

@batman1 Đã sửa Bác kiểm tra lại.

@batman1 Đã sửa Bác kiểm tra lại.

@batman1 Đã sửa Bác kiểm tra lại.