[Chia sẻ] Sắp xếp (sort) trong mảng 2 chiều (Array 2D)

Liên hệ QC
Maika8008

Maika8008

Thành viên gạo cội
Tham gia
12/6/20
Bài viết
4,763
Được thích
5,719
Donate (Momo)
Donate
Giới tính
Nam
Tôi nhớ trên GPE có code sort array đâu đó rồi nhưng quả thực là chức năng tìm kiếm trên GPE sao sao đó mà tôi không tài nào tìm được (!).
Nay tình cờ có được 1 cái Sub sắp xếp 1 cột tăng dần của mảng 2 chiều, tôi sửa lại thành Function và làm thêm 1 cái Function gọi cái kia để sắp xếp thêm cột thứ 2, chia sẻ cho ai đó cần.
(Function trước tôi để nguyên ghi chú của tác giả)
Rich (BB code): 
Function QuickSortArrayF(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1, Optional lngColumn As Long = 0)
    On Error Resume Next

    'Sort a 2-Dimensional array

    ' SampleUsage: sort arrData by the contents of column 3
    '
    '   QuickSortArray arrData, , , 3

    '
    'Posted by Jim Rech 10/20/98 Excel.Programming

    'Modifications, Nigel Heffernan:

    '       ' Escape failed comparison with empty variant
    '       ' Defensive coding: check inputs

    Dim i As Long
    Dim j As Long
    Dim varMid As Variant
    Dim arrRowTemp As Variant
    Dim lngColTemp As Long

    If IsEmpty(SortArray) Then
        Exit Function
    End If
    If InStr(TypeName(SortArray), "()") < 1 Then  'IsArray() is somewhat broken: Look for brackets in the type name
        Exit Function
    End If
    If lngMin = -1 Then
        lngMin = LBound(SortArray, 1)
    End If
    If lngMax = -1 Then
        lngMax = UBound(SortArray, 1)
    End If
    If lngMin >= lngMax Then    ' no sorting required
        Exit Function
    End If

    i = lngMin
    j = lngMax
    
    varMid = Empty
    varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)

    ' We  send 'Empty' and invalid data items to the end of the list:
    If IsObject(varMid) Then  ' note that we don't check isObject(SortArray(n)) - varMid *might* pick up a valid default member or property
        i = lngMax
        j = lngMin
    ElseIf IsEmpty(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf IsNull(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf varMid = "" 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

    While i <= j
        While SortArray(i, lngColumn) < varMid And i < lngMax
            i = i + 1
        Wend
        While varMid < SortArray(j, lngColumn) And j > lngMin
            j = j - 1
        Wend

        If i <= j Then
            ' Swap the rows
            ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))
            For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)
                arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)
                SortArray(i, lngColTemp) = SortArray(j, lngColTemp)
                SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)
            Next lngColTemp
            Erase arrRowTemp

            i = i + 1
            j = j - 1
        End If
    Wend

    If (lngMin < j) Then Call QuickSortArrayF(SortArray, lngMin, j, lngColumn)
    If (i < lngMax) Then Call QuickSortArrayF(SortArray, i, lngMax, lngColumn)
  
    QuickSortArrayF = SortArray
End Function

Function QuickSortArrayF2(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1, Optional lngColumn As Long = 0, Optional lngColumn2 As Long = 0)
Dim SortArr As Variant
Dim i As Long, j As Long, k As Long, d As Long, r As Long
    If lngColumn = 0 Then lngColumn = 1
    SortArray = QuickSortArrayF(SortArray, , , lngColumn)
    ReDim TempArray(1 To UBound(SortArray, 1), 1 To UBound(SortArray, 2))
    For i = LBound(SortArray, 1) To UBound(SortArray, 1)
        k = k + 1
        On Error Resume Next
        If SortArray(i, lngColumn) <> SortArray(i + 1, lngColumn) Then
            If Err.Number = 9 Then
                On Error GoTo 0
                GoTo Sort
            End If
Sort:       If k > 1 Then
                ReDim SortArr(1 To k, 1 To UBound(SortArray, 2))
                For r = 1 To k
                    For j = LBound(SortArray, 2) To UBound(SortArray, 2)
                        SortArr(r, j) = SortArray(i - k + r, j)
                    Next
                Next
                SortArr = QuickSortArrayF(SortArr, , , lngColumn2)
                For d = i - k + 1 To i
                    For j = LBound(SortArray, 2) To UBound(SortArray, 2)
                        SortArray(d, j) = SortArr(d + k - i, j)
                    Next
                Next
                k = 0
            Else
                k = 0
            End If
        End If
    Next
    QuickSortArrayF2 = SortArray
End Function
 
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Maika8008 đã viết:
Tôi nhớ trên GPE có code sort array đâu đó rồi nhưng quả thực là chức năng tìm kiếm trên GPE sao sao đó mà tôi không tài nào tìm được (!).
Nay tình cờ có được 1 cái Sub sắp xếp 1 cột tăng dần của mảng 2 chiều, tôi sửa lại thành Function và làm thêm 1 cái Function gọi cái kia để sắp xếp thêm cột thứ 2, chia sẻ cho ai đó cần.
(Function trước tôi để nguyên ghi chú của tác giả)
Rich (BB code): 
Function QuickSortArrayF(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1, Optional lngColumn As Long = 0)
    On Error Resume Next

    'Sort a 2-Dimensional array

    ' SampleUsage: sort arrData by the contents of column 3
    '
    '   QuickSortArray arrData, , , 3

    '
    'Posted by Jim Rech 10/20/98 Excel.Programming

    'Modifications, Nigel Heffernan:

    '       ' Escape failed comparison with empty variant
    '       ' Defensive coding: check inputs

    Dim i As Long
    Dim j As Long
    Dim varMid As Variant
    Dim arrRowTemp As Variant
    Dim lngColTemp As Long

    If IsEmpty(SortArray) Then
        Exit Function
    End If
    If InStr(TypeName(SortArray), "()") < 1 Then  'IsArray() is somewhat broken: Look for brackets in the type name
        Exit Function
    End If
    If lngMin = -1 Then
        lngMin = LBound(SortArray, 1)
    End If
    If lngMax = -1 Then
        lngMax = UBound(SortArray, 1)
    End If
    If lngMin >= lngMax Then    ' no sorting required
        Exit Function
    End If

    i = lngMin
    j = lngMax
    
    varMid = Empty
    varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)

    ' We  send 'Empty' and invalid data items to the end of the list:
    If IsObject(varMid) Then  ' note that we don't check isObject(SortArray(n)) - varMid *might* pick up a valid default member or property
        i = lngMax
        j = lngMin
    ElseIf IsEmpty(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf IsNull(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf varMid = "" 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

    While i <= j
        While SortArray(i, lngColumn) < varMid And i < lngMax
            i = i + 1
        Wend
        While varMid < SortArray(j, lngColumn) And j > lngMin
            j = j - 1
        Wend

        If i <= j Then
            ' Swap the rows
            ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))
            For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)
                arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)
                SortArray(i, lngColTemp) = SortArray(j, lngColTemp)
                SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)
            Next lngColTemp
            Erase arrRowTemp

            i = i + 1
            j = j - 1
        End If
    Wend

    If (lngMin < j) Then Call QuickSortArrayF(SortArray, lngMin, j, lngColumn)
    If (i < lngMax) Then Call QuickSortArrayF(SortArray, i, lngMax, lngColumn)
  
    QuickSortArrayF = SortArray
End Function

Function QuickSortArrayF2(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1, Optional lngColumn As Long = 0, Optional lngColumn2 As Long = 0)
Dim SortArr As Variant
Dim i As Long, j As Long, k As Long, d As Long, r As Long
  
    SortArray = QuickSortArrayF(SortArray, , , lngColumn)
    ReDim TempArray(1 To UBound(SortArray, 1), 1 To UBound(SortArray, 2))
    For i = LBound(SortArray, 1) To UBound(SortArray, 1)
        k = k + 1
        On Error Resume Next
        If SortArray(i, lngColumn) <> SortArray(i + 1, lngColumn) Then
            If Err.Number = 9 Then
                On Error GoTo 0
                GoTo Sort
            End If
Sort:       If k > 1 Then
                ReDim SortArr(1 To k, 1 To UBound(SortArray, 2))
                For r = 1 To k
                    For j = LBound(SortArray, 2) To UBound(SortArray, 2)
                        SortArr(r, j) = SortArray(i - k + r, j)
                    Next
                Next
                SortArr = QuickSortArrayF(SortArr, , , lngColumn2)
                For d = i - k + 1 To i
                    For j = LBound(SortArray, 2) To UBound(SortArray, 2)
                        SortArray(d, j) = SortArr(d + k - i, j)
                    Next
                Next
                k = 0
            Else
                k = 0
            End If
        End If
    Next
    QuickSortArrayF2 = SortArray
End Function
Nhấp chuột vào đây để mở rộng...
Trước đây tôi cũng có tìm kiếm vấn đề này nhưng chưa xử lý được.
Bạn có thể cho ví dụ về cách sử dụng hàm này như thế nào được không?
Cảm ơn
 
Upvote 0
Maika8008 đã viết:
Tôi nhớ trên GPE có code sort array đâu đó rồi nhưng quả thực là chức năng tìm kiếm trên GPE sao sao đó mà tôi không tài nào tìm được (!).
Nay tình cờ có được 1 cái Sub sắp xếp 1 cột tăng dần của mảng 2 chiều, tôi sửa lại thành Function và làm thêm 1 cái Function gọi cái kia để sắp xếp thêm cột thứ 2, chia sẻ cho ai đó cần.
(Function trước tôi để nguyên ghi chú của tác giả)
Rich (BB code): 
Function QuickSortArrayF(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1, Optional lngColumn As Long = 0)
    On Error Resume Next

    'Sort a 2-Dimensional array

    ' SampleUsage: sort arrData by the contents of column 3
    '
    '   QuickSortArray arrData, , , 3

    '
    'Posted by Jim Rech 10/20/98 Excel.Programming

    'Modifications, Nigel Heffernan:

    '       ' Escape failed comparison with empty variant
    '       ' Defensive coding: check inputs

    Dim i As Long
    Dim j As Long
    Dim varMid As Variant
    Dim arrRowTemp As Variant
    Dim lngColTemp As Long

    If IsEmpty(SortArray) Then
        Exit Function
    End If
    If InStr(TypeName(SortArray), "()") < 1 Then  'IsArray() is somewhat broken: Look for brackets in the type name
        Exit Function
    End If
    If lngMin = -1 Then
        lngMin = LBound(SortArray, 1)
    End If
    If lngMax = -1 Then
        lngMax = UBound(SortArray, 1)
    End If
    If lngMin >= lngMax Then    ' no sorting required
        Exit Function
    End If

    i = lngMin
    j = lngMax
    
    varMid = Empty
    varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)

    ' We  send 'Empty' and invalid data items to the end of the list:
    If IsObject(varMid) Then  ' note that we don't check isObject(SortArray(n)) - varMid *might* pick up a valid default member or property
        i = lngMax
        j = lngMin
    ElseIf IsEmpty(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf IsNull(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf varMid = "" 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

    While i <= j
        While SortArray(i, lngColumn) < varMid And i < lngMax
            i = i + 1
        Wend
        While varMid < SortArray(j, lngColumn) And j > lngMin
            j = j - 1
        Wend

        If i <= j Then
            ' Swap the rows
            ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))
            For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)
                arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)
                SortArray(i, lngColTemp) = SortArray(j, lngColTemp)
                SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)
            Next lngColTemp
            Erase arrRowTemp

            i = i + 1
            j = j - 1
        End If
    Wend

    If (lngMin < j) Then Call QuickSortArrayF(SortArray, lngMin, j, lngColumn)
    If (i < lngMax) Then Call QuickSortArrayF(SortArray, i, lngMax, lngColumn)
  
    QuickSortArrayF = SortArray
End Function

Function QuickSortArrayF2(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1, Optional lngColumn As Long = 0, Optional lngColumn2 As Long = 0)
Dim SortArr As Variant
Dim i As Long, j As Long, k As Long, d As Long, r As Long
  
    SortArray = QuickSortArrayF(SortArray, , , lngColumn)
    ReDim TempArray(1 To UBound(SortArray, 1), 1 To UBound(SortArray, 2))
    For i = LBound(SortArray, 1) To UBound(SortArray, 1)
        k = k + 1
        On Error Resume Next
        If SortArray(i, lngColumn) <> SortArray(i + 1, lngColumn) Then
            If Err.Number = 9 Then
                On Error GoTo 0
                GoTo Sort
            End If
Sort:       If k > 1 Then
                ReDim SortArr(1 To k, 1 To UBound(SortArray, 2))
                For r = 1 To k
                    For j = LBound(SortArray, 2) To UBound(SortArray, 2)
                        SortArr(r, j) = SortArray(i - k + r, j)
                    Next
                Next
                SortArr = QuickSortArrayF(SortArr, , , lngColumn2)
                For d = i - k + 1 To i
                    For j = LBound(SortArray, 2) To UBound(SortArray, 2)
                        SortArray(d, j) = SortArr(d + k - i, j)
                    Next
                Next
                k = 0
            Else
                k = 0
            End If
        End If
    Next
    QuickSortArrayF2 = SortArray
End Function
Nhấp chuột vào đây để mở rộng...
Cho hỏi code này sort loại dữ liệu nào vậy bạn
 
Upvote 0
Pi-Pikachu đã viết:
Trước đây tôi cũng có tìm kiếm vấn đề này nhưng chưa xử lý được.
Bạn có thể cho ví dụ về cách sử dụng hàm này như thế nào được không?
Cảm ơn
Nhấp chuột vào đây để mở rộng...
1/ QuickSortArrayF(YourArray, , ,Cột cần sort) => Bỏ qua lngMin, lngMax vì thường là sort toàn bộ các dòng trong mảng. Còn không thì chỉ định sort từ lngMin tới lngMax
2/ QuickSortArrayF(YourArray, , ,Cột cần sort1, Cột cần sort2)
Bài đã được tự động gộp:

CHAOQUAY đã viết:
Cho hỏi code này sort loại dữ liệu nào vậy bạn
Nhấp chuột vào đây để mở rộng...
Kiểu text, number hoặc date
 
Upvote 0

Maika8008​

QuickSortArrayF2 gọi QuickSortArrayF trong vòng lặp là một 'cuộc chơi' sai lầm
Sửa QuickSortArrayF là được QuickSortArrayF2

Đây là công trình sửa code của tôi cách đây chắc 2 năm trước của tôi bác tham khảo:

JavaScript: 
Private Sub ArrayQuickSort_test()
  Dim Arr, arr2, t As Double: t = Timer
  Dim bHorizontal As Boolean
  bHorizontal = False
  Arr = [F3:J7].value
  ArrayQuickSort2 Arr, 1, , bHorizontal, , , arr2
  [F10:J14].value = Arr
  '----------------------------
  Arr = [F3:K8].value
  ArrayQuickSort2 Arr, 1, , bHorizontal, , , arr2
  [F16:K21].value = Arr
  '----------------------------

  Arr = [F3:J7].value
  ArrayQuickSort2 Arr, 1, True, bHorizontal, , , arr2
  [F23:J27].value = Arr
  '----------------------------
  Arr = [F3:K8].value
  ArrayQuickSort2 Arr, 1, True, bHorizontal, , , arr2
  Debug.Print join(arr2, ",")
  [F29:K34].value = Arr
  Debug.Print Round(Timer - t, 5)
End Sub

Sub ArrayQuickSort(ByRef ArrayIn As Variant, _
                Optional lngIndex As Long = 0, _
                Optional bDescending As Boolean = False, _
                Optional bHorizontal As Boolean = False, _
                Optional LngMin As Long = -1, _
                Optional LngMax As Long = -1, _
                Optional ArraySwapped As Variant)
  On Error Resume Next
  Dim i As Long, J As Long, R As Long, v As Variant, t As Variant, s()
  If IsEmpty(ArrayIn) Then Exit Sub
  If VBA.InStr(TypeName(ArrayIn), "()") < 1 Then Exit Sub
  v = Empty
  If bHorizontal Then
    If LngMin = -1 Then LngMin = LBound(ArrayIn, 2)
    If LngMax = -1 Then LngMax = UBound(ArrayIn, 2)
    v = ArrayIn(lngIndex, (LngMin + LngMax) \ 2)
  Else
    If LngMin = -1 Then LngMin = LBound(ArrayIn, 1)
    If LngMax = -1 Then LngMax = UBound(ArrayIn, 1)
    v = ArrayIn((LngMin + LngMax) \ 2, lngIndex)
  End If

  If LngMin >= LngMax Then Exit Sub
  i = LngMin: J = LngMax
  Select Case True
  Case VBA.IsObject(v): i = LngMax: J = LngMin
  Case IsEmpty(v): i = LngMax: J = LngMin
  Case IsNull(v): i = LngMax: J = LngMin
  Case v = vbNullString: i = LngMax: J = LngMin
  Case VBA.VarType(v) = vbError: i = LngMax: J = LngMin
  Case VBA.VarType(v) > 17: i = LngMax: J = LngMin
  End Select
  If bHorizontal Then
    If bDescending Then
      While i <= J
        While ArrayIn(lngIndex, i) > v And i < LngMax: i = i + 1: Wend
        While v > ArrayIn(lngIndex, J) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
            t = ArrayIn(R, i)
            ArrayIn(R, i) = ArrayIn(R, J)
            ArrayIn(R, J) = t
          Next R
          i = i + 1: J = J - 1
        End If
      Wend
    Else
      While i <= J
        While ArrayIn(lngIndex, i) < v And i < LngMax: i = i + 1: Wend
        While v < ArrayIn(lngIndex, J) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
            t = ArrayIn(R, i)
            ArrayIn(R, i) = ArrayIn(R, J)
            ArrayIn(R, J) = t
          Next R
          i = i + 1: J = J - 1
        End If
      Wend
    End If
  Else
    If bDescending Then
      While i <= J
        While ArrayIn(i, lngIndex) > v And i < LngMax: i = i + 1: Wend
        While v > ArrayIn(J, lngIndex) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
            t = ArrayIn(i, R)
            ArrayIn(i, R) = ArrayIn(J, R)
            ArrayIn(J, R) = t
          Next R
          i = i + 1: J = J - 1
        End If
      Wend
    Else
      While i <= J
        While ArrayIn(i, lngIndex) < v And i < LngMax: i = i + 1: Wend
        While v < ArrayIn(J, lngIndex) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
            t = ArrayIn(i, R)
            ArrayIn(i, R) = ArrayIn(J, R)
            ArrayIn(J, R) = t
          Next R
          i = i + 1: J = J - 1
        End If
      Wend
    End If
  End If
  If (LngMin < J) Then Call ArrayQuickSort(ArrayIn, lngIndex, bDescending, bHorizontal, LngMin, J, ArraySwapped)
  If (i < LngMax) Then Call ArrayQuickSort(ArrayIn, lngIndex, bDescending, bHorizontal, i, LngMax, ArraySwapped)
End Sub
Sub ArrayQuickSort2(ByRef ArrayIn As Variant, _
                Optional lngIndex As Long = 0, _
                Optional bDescending As Boolean = False, _
                Optional bHorizontal As Boolean = False, _
                Optional LngMin As Long = -1, _
                Optional LngMax As Long = -1, _
                Optional ArraySwapped As Variant)
  On Error Resume Next
  Dim i As Long, J As Long, R As Long, c As Long, v As Variant, t As Variant, s()
  If IsEmpty(ArrayIn) Then Exit Sub
  If VBA.InStr(TypeName(ArrayIn), "()") < 1 Then Exit Sub
  v = Empty
  If bHorizontal Then
    c = LBound(ArrayIn, 2): R = UBound(ArrayIn, 2)
    If LngMin = -1 Then LngMin = c
    If LngMax = -1 Then LngMax = R
    v = ArrayIn(lngIndex, (LngMin + LngMax) \ 2)
  Else
    c = LBound(ArrayIn, 1): R = UBound(ArrayIn, 1)
    If LngMin = -1 Then LngMin = c
    If LngMax = -1 Then LngMax = R
    v = ArrayIn((LngMin + LngMax) \ 2, lngIndex)
  End If
  If VBA.InStr(TypeName(ArraySwapped), "()") < 1 Then
    ReDim s(c To R): For i = c To R: s(i) = i: Next
    ArraySwapped = s
  End If
  If LngMin >= LngMax Then Exit Sub
  i = LngMin: J = LngMax
  Select Case True
  Case VBA.IsObject(v): i = LngMax: J = LngMin
  Case IsEmpty(v): i = LngMax: J = LngMin
  Case IsNull(v): i = LngMax: J = LngMin
  Case v = vbNullString: i = LngMax: J = LngMin
  Case VBA.VarType(v) = vbError: i = LngMax: J = LngMin
  Case VBA.VarType(v) > 17: i = LngMax: J = LngMin
  End Select
  If bHorizontal Then
    If bDescending Then
      While i <= J
        While ArrayIn(lngIndex, i) > v And i < LngMax: i = i + 1: Wend
        While v > ArrayIn(lngIndex, J) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
            t = ArrayIn(R, i): ArrayIn(R, i) = ArrayIn(R, J): ArrayIn(R, J) = t
          Next R
          t = ArraySwapped(i): ArraySwapped(i) = ArraySwapped(J): ArraySwapped(J) = t
          i = i + 1: J = J - 1
        End If
      Wend
    Else
      While i <= J
        While ArrayIn(lngIndex, i) < v And i < LngMax: i = i + 1: Wend
        While v < ArrayIn(lngIndex, J) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
            t = ArrayIn(R, i): ArrayIn(R, i) = ArrayIn(R, J): ArrayIn(R, J) = t
          Next R
          t = ArraySwapped(i): ArraySwapped(i) = ArraySwapped(J): ArraySwapped(J) = t
          i = i + 1: J = J - 1
        End If
      Wend
    End If
  Else
    If bDescending Then
      While i <= J
        While ArrayIn(i, lngIndex) > v And i < LngMax: i = i + 1: Wend
        While v > ArrayIn(J, lngIndex) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
            t = ArrayIn(i, R): ArrayIn(i, R) = ArrayIn(J, R): ArrayIn(J, R) = t
          Next R
          t = ArraySwapped(i): ArraySwapped(i) = ArraySwapped(J): ArraySwapped(J) = t
          i = i + 1: J = J - 1
        End If
      Wend
    Else
      While i <= J
        While ArrayIn(i, lngIndex) < v And i < LngMax: i = i + 1: Wend
        While v < ArrayIn(J, lngIndex) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
            t = ArrayIn(i, R): ArrayIn(i, R) = ArrayIn(J, R): ArrayIn(J, R) = t
          Next R
          t = ArraySwapped(i): ArraySwapped(i) = ArraySwapped(J): ArraySwapped(J) = t
          i = i + 1: J = J - 1
        End If
      Wend
    End If
  End If
  If (LngMin < J) Then Call ArrayQuickSort(ArrayIn, lngIndex, bDescending, bHorizontal, LngMin, J, ArraySwapped)
  If (i < LngMax) Then Call ArrayQuickSort(ArrayIn, lngIndex, bDescending, bHorizontal, i, LngMax, ArraySwapped)
End Sub
Private Sub ArrayQuickSortV_test()
  Dim Arr, t As Double: t = Timer
  Arr = [F3:J7].value
  ArrayQuickSortV Arr, 1
  [F10:J14].value = Arr
  '----------------------------
  Arr = [F3:K8].value
  ArrayQuickSortV Arr, 1
  [F16:K21].value = Arr
  '----------------------------

  Arr = [F3:J7].value
  ArrayQuickSortV Arr, 1, True
  [F23:J27].value = Arr
  '----------------------------
  Arr = [F3:K8].value
  ArrayQuickSortV Arr, 1, True
  [F29:K34].value = Arr
  Debug.Print Round(Timer - t, 5)
End Sub
Sub ArrayQuickSortV(ByRef ArrayIn As Variant, _
                Optional lngColumn As Long = 0, _
                Optional bDescending As Boolean = False, _
                Optional LngMin& = -1, _
                Optional LngMax& = -1)
  On Error Resume Next
  Dim i&, J&
  Dim varMid As Variant, Tmp As Variant, lngColTemp&
  If IsEmpty(ArrayIn) Then Exit Sub
  If VBA.InStr(TypeName(ArrayIn), "()") < 1 Then Exit Sub
  If LngMin = -1 Then LngMin = LBound(ArrayIn, 1)
  If LngMax = -1 Then LngMax = UBound(ArrayIn, 1)
  ' no sorting required
  If LngMin >= LngMax Then Exit Sub
  i = LngMin: J = LngMax
  varMid = Empty
  varMid = ArrayIn((LngMin + LngMax) \ 2, lngColumn)
  Select Case True
  Case VBA.IsObject(varMid): i = LngMax: J = LngMin
  Case IsEmpty(varMid): i = LngMax: J = LngMin
  Case IsNull(varMid): i = LngMax: J = LngMin
  Case varMid = "": i = LngMax: J = LngMin
  Case VBA.VarType(varMid) = vbError: i = LngMax: J = LngMin
  Case VBA.VarType(varMid) > 17: i = LngMax: J = LngMin
  End Select
  If bDescending Then
    While i <= J
      While ArrayIn(i, lngColumn) > varMid And i < LngMax: i = i + 1: Wend
      While varMid > ArrayIn(J, lngColumn) And J > LngMin: J = J - 1: Wend
      If i <= J Then
        For lngColTemp = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
          Tmp = ArrayIn(i, lngColTemp)
          ArrayIn(i, lngColTemp) = ArrayIn(J, lngColTemp)
          ArrayIn(J, lngColTemp) = Tmp
        Next lngColTemp
        i = i + 1: J = J - 1
      End If
    Wend
  Else
    While i <= J
      While ArrayIn(i, lngColumn) < varMid And i < LngMax: i = i + 1: Wend
      While varMid < ArrayIn(J, lngColumn) And J > LngMin: J = J - 1: Wend
      If i <= J Then
        For lngColTemp = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
          Tmp = ArrayIn(i, lngColTemp)
          ArrayIn(i, lngColTemp) = ArrayIn(J, lngColTemp)
          ArrayIn(J, lngColTemp) = Tmp
        Next lngColTemp
        i = i + 1: J = J - 1
      End If
    Wend
  End If
  If (LngMin < J) Then Call ArrayQuickSortV(ArrayIn, lngColumn, bDescending, LngMin, J)
  If (i < LngMax) Then Call ArrayQuickSortV(ArrayIn, lngColumn, bDescending, i, LngMax)
End Sub
Sub ArrayQuickSortH(ByRef ArrayIn As Variant, _
                 Optional lngColumn& = 0, _
                 Optional bDescending As Boolean, _
                 Optional LngMin& = -1, _
                 Optional LngMax& = -1)
  On Error Resume Next
  Dim i&, J&
  Dim varMid As Variant, arrRowTemp As Variant
  Dim lngColTemp&
  If IsEmpty(ArrayIn) Then Exit Sub
  If VBA.InStr(TypeName(ArrayIn), "()") < 1 Then Exit Sub
  If LngMin = -1 Then LngMin = LBound(ArrayIn, 2)
  If LngMax = -1 Then LngMax = UBound(ArrayIn, 2)
  If LngMin >= LngMax Then Exit Sub
  i = LngMin: J = LngMax
  varMid = Empty
  varMid = ArrayIn(lngColumn, (LngMin + LngMax) \ 2)
  Select Case True
  Case VBA.IsObject(varMid): i = LngMax: J = LngMin
  Case IsEmpty(varMid): i = LngMax: J = LngMin
  Case IsNull(varMid): i = LngMax: J = LngMin
  Case varMid = "": i = LngMax: J = LngMin
  Case VBA.VarType(varMid) = vbError: i = LngMax: J = LngMin
  Case VBA.VarType(varMid) > 17: i = LngMax: J = LngMin
  End Select
  If bDescending Then
    While i <= J
      While ArrayIn(lngColumn, i) > varMid And i < LngMax: i = i + 1: Wend
      While varMid > ArrayIn(lngColumn, J) And J > LngMin: J = J - 1: Wend
      If i <= J Then
        ReDim arrRowTemp(LBound(ArrayIn, 1) To UBound(ArrayIn, 1))
        For lngColTemp = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
          arrRowTemp(lngColTemp) = ArrayIn(lngColTemp, i)
          ArrayIn(lngColTemp, i) = ArrayIn(lngColTemp, J)
          ArrayIn(lngColTemp, J) = arrRowTemp(lngColTemp)
        Next lngColTemp
        Erase arrRowTemp
        i = i + 1: J = J - 1
      End If
    Wend
  Else
    While i <= J
      While ArrayIn(lngColumn, i) < varMid And i < LngMax: i = i + 1: Wend
      While varMid < ArrayIn(lngColumn, J) And J > LngMin: J = J - 1: Wend
      If i <= J Then
        ReDim arrRowTemp(LBound(ArrayIn, 1) To UBound(ArrayIn, 1))
        For lngColTemp = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
          arrRowTemp(lngColTemp) = ArrayIn(lngColTemp, i)
          ArrayIn(lngColTemp, i) = ArrayIn(lngColTemp, J)
          ArrayIn(lngColTemp, J) = arrRowTemp(lngColTemp)
        Next lngColTemp
        Erase arrRowTemp
        i = i + 1: J = J - 1
      End If
    Wend
  End If
  If (LngMin < J) Then Call ArrayQuickSortH(ArrayIn, lngColumn, bDescending, LngMin, J)
  If (i < LngMax) Then Call ArrayQuickSortH(ArrayIn, lngColumn, bDescending, i, LngMax)
End Sub
 
Upvote 0
HeSanbi đã viết:

Maika8008​

QuickSortArrayF2 gọi QuickSortArrayF trong vòng lặp là một 'cuộc chơi' sai lầm
Sửa QuickSortArrayF là được QuickSortArrayF2

Đây là công trình sửa code của tôi cách đây chắc 2 năm trước của tôi bác tham khảo:

JavaScript: 
Private Sub ArrayQuickSort_test()
  Dim Arr, arr2, t As Double: t = Timer
  Dim bHorizontal As Boolean
  bHorizontal = False
  Arr = [F3:J7].value
  ArrayQuickSort2 Arr, 1, , bHorizontal, , , arr2
  [F10:J14].value = Arr
  '----------------------------
  Arr = [F3:K8].value
  ArrayQuickSort2 Arr, 1, , bHorizontal, , , arr2
  [F16:K21].value = Arr
  '----------------------------

  Arr = [F3:J7].value
  ArrayQuickSort2 Arr, 1, True, bHorizontal, , , arr2
  [F23:J27].value = Arr
  '----------------------------
  Arr = [F3:K8].value
  ArrayQuickSort2 Arr, 1, True, bHorizontal, , , arr2
  Debug.Print join(arr2, ",")
  [F29:K34].value = Arr
  Debug.Print Round(Timer - t, 5)
End Sub

Sub ArrayQuickSort(ByRef ArrayIn As Variant, _
                Optional lngIndex As Long = 0, _
                Optional bDescending As Boolean = False, _
                Optional bHorizontal As Boolean = False, _
                Optional LngMin As Long = -1, _
                Optional LngMax As Long = -1, _
                Optional ArraySwapped As Variant)
  On Error Resume Next
  Dim i As Long, J As Long, R As Long, v As Variant, t As Variant, s()
  If IsEmpty(ArrayIn) Then Exit Sub
  If VBA.InStr(TypeName(ArrayIn), "()") < 1 Then Exit Sub
  v = Empty
  If bHorizontal Then
    If LngMin = -1 Then LngMin = LBound(ArrayIn, 2)
    If LngMax = -1 Then LngMax = UBound(ArrayIn, 2)
    v = ArrayIn(lngIndex, (LngMin + LngMax) \ 2)
  Else
    If LngMin = -1 Then LngMin = LBound(ArrayIn, 1)
    If LngMax = -1 Then LngMax = UBound(ArrayIn, 1)
    v = ArrayIn((LngMin + LngMax) \ 2, lngIndex)
  End If

  If LngMin >= LngMax Then Exit Sub
  i = LngMin: J = LngMax
  Select Case True
  Case VBA.IsObject(v): i = LngMax: J = LngMin
  Case IsEmpty(v): i = LngMax: J = LngMin
  Case IsNull(v): i = LngMax: J = LngMin
  Case v = vbNullString: i = LngMax: J = LngMin
  Case VBA.VarType(v) = vbError: i = LngMax: J = LngMin
  Case VBA.VarType(v) > 17: i = LngMax: J = LngMin
  End Select
  If bHorizontal Then
    If bDescending Then
      While i <= J
        While ArrayIn(lngIndex, i) > v And i < LngMax: i = i + 1: Wend
        While v > ArrayIn(lngIndex, J) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
            t = ArrayIn(R, i)
            ArrayIn(R, i) = ArrayIn(R, J)
            ArrayIn(R, J) = t
          Next R
          i = i + 1: J = J - 1
        End If
      Wend
    Else
      While i <= J
        While ArrayIn(lngIndex, i) < v And i < LngMax: i = i + 1: Wend
        While v < ArrayIn(lngIndex, J) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
            t = ArrayIn(R, i)
            ArrayIn(R, i) = ArrayIn(R, J)
            ArrayIn(R, J) = t
          Next R
          i = i + 1: J = J - 1
        End If
      Wend
    End If
  Else
    If bDescending Then
      While i <= J
        While ArrayIn(i, lngIndex) > v And i < LngMax: i = i + 1: Wend
        While v > ArrayIn(J, lngIndex) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
            t = ArrayIn(i, R)
            ArrayIn(i, R) = ArrayIn(J, R)
            ArrayIn(J, R) = t
          Next R
          i = i + 1: J = J - 1
        End If
      Wend
    Else
      While i <= J
        While ArrayIn(i, lngIndex) < v And i < LngMax: i = i + 1: Wend
        While v < ArrayIn(J, lngIndex) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
            t = ArrayIn(i, R)
            ArrayIn(i, R) = ArrayIn(J, R)
            ArrayIn(J, R) = t
          Next R
          i = i + 1: J = J - 1
        End If
      Wend
    End If
  End If
  If (LngMin < J) Then Call ArrayQuickSort(ArrayIn, lngIndex, bDescending, bHorizontal, LngMin, J, ArraySwapped)
  If (i < LngMax) Then Call ArrayQuickSort(ArrayIn, lngIndex, bDescending, bHorizontal, i, LngMax, ArraySwapped)
End Sub
Sub ArrayQuickSort2(ByRef ArrayIn As Variant, _
                Optional lngIndex As Long = 0, _
                Optional bDescending As Boolean = False, _
                Optional bHorizontal As Boolean = False, _
                Optional LngMin As Long = -1, _
                Optional LngMax As Long = -1, _
                Optional ArraySwapped As Variant)
  On Error Resume Next
  Dim i As Long, J As Long, R As Long, c As Long, v As Variant, t As Variant, s()
  If IsEmpty(ArrayIn) Then Exit Sub
  If VBA.InStr(TypeName(ArrayIn), "()") < 1 Then Exit Sub
  v = Empty
  If bHorizontal Then
    c = LBound(ArrayIn, 2): R = UBound(ArrayIn, 2)
    If LngMin = -1 Then LngMin = c
    If LngMax = -1 Then LngMax = R
    v = ArrayIn(lngIndex, (LngMin + LngMax) \ 2)
  Else
    c = LBound(ArrayIn, 1): R = UBound(ArrayIn, 1)
    If LngMin = -1 Then LngMin = c
    If LngMax = -1 Then LngMax = R
    v = ArrayIn((LngMin + LngMax) \ 2, lngIndex)
  End If
  If VBA.InStr(TypeName(ArraySwapped), "()") < 1 Then
    ReDim s(c To R): For i = c To R: s(i) = i: Next
    ArraySwapped = s
  End If
  If LngMin >= LngMax Then Exit Sub
  i = LngMin: J = LngMax
  Select Case True
  Case VBA.IsObject(v): i = LngMax: J = LngMin
  Case IsEmpty(v): i = LngMax: J = LngMin
  Case IsNull(v): i = LngMax: J = LngMin
  Case v = vbNullString: i = LngMax: J = LngMin
  Case VBA.VarType(v) = vbError: i = LngMax: J = LngMin
  Case VBA.VarType(v) > 17: i = LngMax: J = LngMin
  End Select
  If bHorizontal Then
    If bDescending Then
      While i <= J
        While ArrayIn(lngIndex, i) > v And i < LngMax: i = i + 1: Wend
        While v > ArrayIn(lngIndex, J) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
            t = ArrayIn(R, i): ArrayIn(R, i) = ArrayIn(R, J): ArrayIn(R, J) = t
          Next R
          t = ArraySwapped(i): ArraySwapped(i) = ArraySwapped(J): ArraySwapped(J) = t
          i = i + 1: J = J - 1
        End If
      Wend
    Else
      While i <= J
        While ArrayIn(lngIndex, i) < v And i < LngMax: i = i + 1: Wend
        While v < ArrayIn(lngIndex, J) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
            t = ArrayIn(R, i): ArrayIn(R, i) = ArrayIn(R, J): ArrayIn(R, J) = t
          Next R
          t = ArraySwapped(i): ArraySwapped(i) = ArraySwapped(J): ArraySwapped(J) = t
          i = i + 1: J = J - 1
        End If
      Wend
    End If
  Else
    If bDescending Then
      While i <= J
        While ArrayIn(i, lngIndex) > v And i < LngMax: i = i + 1: Wend
        While v > ArrayIn(J, lngIndex) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
            t = ArrayIn(i, R): ArrayIn(i, R) = ArrayIn(J, R): ArrayIn(J, R) = t
          Next R
          t = ArraySwapped(i): ArraySwapped(i) = ArraySwapped(J): ArraySwapped(J) = t
          i = i + 1: J = J - 1
        End If
      Wend
    Else
      While i <= J
        While ArrayIn(i, lngIndex) < v And i < LngMax: i = i + 1: Wend
        While v < ArrayIn(J, lngIndex) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
            t = ArrayIn(i, R): ArrayIn(i, R) = ArrayIn(J, R): ArrayIn(J, R) = t
          Next R
          t = ArraySwapped(i): ArraySwapped(i) = ArraySwapped(J): ArraySwapped(J) = t
          i = i + 1: J = J - 1
        End If
      Wend
    End If
  End If
  If (LngMin < J) Then Call ArrayQuickSort(ArrayIn, lngIndex, bDescending, bHorizontal, LngMin, J, ArraySwapped)
  If (i < LngMax) Then Call ArrayQuickSort(ArrayIn, lngIndex, bDescending, bHorizontal, i, LngMax, ArraySwapped)
End Sub
Private Sub ArrayQuickSortV_test()
  Dim Arr, t As Double: t = Timer
  Arr = [F3:J7].value
  ArrayQuickSortV Arr, 1
  [F10:J14].value = Arr
  '----------------------------
  Arr = [F3:K8].value
  ArrayQuickSortV Arr, 1
  [F16:K21].value = Arr
  '----------------------------

  Arr = [F3:J7].value
  ArrayQuickSortV Arr, 1, True
  [F23:J27].value = Arr
  '----------------------------
  Arr = [F3:K8].value
  ArrayQuickSortV Arr, 1, True
  [F29:K34].value = Arr
  Debug.Print Round(Timer - t, 5)
End Sub
Sub ArrayQuickSortV(ByRef ArrayIn As Variant, _
                Optional lngColumn As Long = 0, _
                Optional bDescending As Boolean = False, _
                Optional LngMin& = -1, _
                Optional LngMax& = -1)
  On Error Resume Next
  Dim i&, J&
  Dim varMid As Variant, Tmp As Variant, lngColTemp&
  If IsEmpty(ArrayIn) Then Exit Sub
  If VBA.InStr(TypeName(ArrayIn), "()") < 1 Then Exit Sub
  If LngMin = -1 Then LngMin = LBound(ArrayIn, 1)
  If LngMax = -1 Then LngMax = UBound(ArrayIn, 1)
  ' no sorting required
  If LngMin >= LngMax Then Exit Sub
  i = LngMin: J = LngMax
  varMid = Empty
  varMid = ArrayIn((LngMin + LngMax) \ 2, lngColumn)
  Select Case True
  Case VBA.IsObject(varMid): i = LngMax: J = LngMin
  Case IsEmpty(varMid): i = LngMax: J = LngMin
  Case IsNull(varMid): i = LngMax: J = LngMin
  Case varMid = "": i = LngMax: J = LngMin
  Case VBA.VarType(varMid) = vbError: i = LngMax: J = LngMin
  Case VBA.VarType(varMid) > 17: i = LngMax: J = LngMin
  End Select
  If bDescending Then
    While i <= J
      While ArrayIn(i, lngColumn) > varMid And i < LngMax: i = i + 1: Wend
      While varMid > ArrayIn(J, lngColumn) And J > LngMin: J = J - 1: Wend
      If i <= J Then
        For lngColTemp = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
          Tmp = ArrayIn(i, lngColTemp)
          ArrayIn(i, lngColTemp) = ArrayIn(J, lngColTemp)
          ArrayIn(J, lngColTemp) = Tmp
        Next lngColTemp
        i = i + 1: J = J - 1
      End If
    Wend
  Else
    While i <= J
      While ArrayIn(i, lngColumn) < varMid And i < LngMax: i = i + 1: Wend
      While varMid < ArrayIn(J, lngColumn) And J > LngMin: J = J - 1: Wend
      If i <= J Then
        For lngColTemp = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
          Tmp = ArrayIn(i, lngColTemp)
          ArrayIn(i, lngColTemp) = ArrayIn(J, lngColTemp)
          ArrayIn(J, lngColTemp) = Tmp
        Next lngColTemp
        i = i + 1: J = J - 1
      End If
    Wend
  End If
  If (LngMin < J) Then Call ArrayQuickSortV(ArrayIn, lngColumn, bDescending, LngMin, J)
  If (i < LngMax) Then Call ArrayQuickSortV(ArrayIn, lngColumn, bDescending, i, LngMax)
End Sub
Sub ArrayQuickSortH(ByRef ArrayIn As Variant, _
                 Optional lngColumn& = 0, _
                 Optional bDescending As Boolean, _
                 Optional LngMin& = -1, _
                 Optional LngMax& = -1)
  On Error Resume Next
  Dim i&, J&
  Dim varMid As Variant, arrRowTemp As Variant
  Dim lngColTemp&
  If IsEmpty(ArrayIn) Then Exit Sub
  If VBA.InStr(TypeName(ArrayIn), "()") < 1 Then Exit Sub
  If LngMin = -1 Then LngMin = LBound(ArrayIn, 2)
  If LngMax = -1 Then LngMax = UBound(ArrayIn, 2)
  If LngMin >= LngMax Then Exit Sub
  i = LngMin: J = LngMax
  varMid = Empty
  varMid = ArrayIn(lngColumn, (LngMin + LngMax) \ 2)
  Select Case True
  Case VBA.IsObject(varMid): i = LngMax: J = LngMin
  Case IsEmpty(varMid): i = LngMax: J = LngMin
  Case IsNull(varMid): i = LngMax: J = LngMin
  Case varMid = "": i = LngMax: J = LngMin
  Case VBA.VarType(varMid) = vbError: i = LngMax: J = LngMin
  Case VBA.VarType(varMid) > 17: i = LngMax: J = LngMin
  End Select
  If bDescending Then
    While i <= J
      While ArrayIn(lngColumn, i) > varMid And i < LngMax: i = i + 1: Wend
      While varMid > ArrayIn(lngColumn, J) And J > LngMin: J = J - 1: Wend
      If i <= J Then
        ReDim arrRowTemp(LBound(ArrayIn, 1) To UBound(ArrayIn, 1))
        For lngColTemp = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
          arrRowTemp(lngColTemp) = ArrayIn(lngColTemp, i)
          ArrayIn(lngColTemp, i) = ArrayIn(lngColTemp, J)
          ArrayIn(lngColTemp, J) = arrRowTemp(lngColTemp)
        Next lngColTemp
        Erase arrRowTemp
        i = i + 1: J = J - 1
      End If
    Wend
  Else
    While i <= J
      While ArrayIn(lngColumn, i) < varMid And i < LngMax: i = i + 1: Wend
      While varMid < ArrayIn(lngColumn, J) And J > LngMin: J = J - 1: Wend
      If i <= J Then
        ReDim arrRowTemp(LBound(ArrayIn, 1) To UBound(ArrayIn, 1))
        For lngColTemp = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
          arrRowTemp(lngColTemp) = ArrayIn(lngColTemp, i)
          ArrayIn(lngColTemp, i) = ArrayIn(lngColTemp, J)
          ArrayIn(lngColTemp, J) = arrRowTemp(lngColTemp)
        Next lngColTemp
        Erase arrRowTemp
        i = i + 1: J = J - 1
      End If
    Wend
  End If
  If (LngMin < J) Then Call ArrayQuickSortH(ArrayIn, lngColumn, bDescending, LngMin, J)
  If (i < LngMax) Then Call ArrayQuickSortH(ArrayIn, lngColumn, bDescending, i, LngMax)
End Sub
Nhấp chuột vào đây để mở rộng...
Hihi. Tôi nghĩ được cách gì thì làm cách ấy thôi. Định sửa cái hàm đầu nhưng thấy dài dòng quá bèn gọi nó lên cho tiện.
 
Upvote 0
HeSanbi đã viết:

Maika8008​

QuickSortArrayF2 gọi QuickSortArrayF trong vòng lặp là một 'cuộc chơi' sai lầm
Sửa QuickSortArrayF là được QuickSortArrayF2

Đây là công trình sửa code của tôi cách đây chắc 2 năm trước của tôi bác tham khảo:

JavaScript: 
Private Sub ArrayQuickSort_test()
  Dim Arr, arr2, t As Double: t = Timer
  Dim bHorizontal As Boolean
  bHorizontal = False
  Arr = [F3:J7].value
  ArrayQuickSort2 Arr, 1, , bHorizontal, , , arr2
  [F10:J14].value = Arr
  '----------------------------
  Arr = [F3:K8].value
  ArrayQuickSort2 Arr, 1, , bHorizontal, , , arr2
  [F16:K21].value = Arr
  '----------------------------

  Arr = [F3:J7].value
  ArrayQuickSort2 Arr, 1, True, bHorizontal, , , arr2
  [F23:J27].value = Arr
  '----------------------------
  Arr = [F3:K8].value
  ArrayQuickSort2 Arr, 1, True, bHorizontal, , , arr2
  Debug.Print join(arr2, ",")
  [F29:K34].value = Arr
  Debug.Print Round(Timer - t, 5)
End Sub

Sub ArrayQuickSort(ByRef ArrayIn As Variant, _
                Optional lngIndex As Long = 0, _
                Optional bDescending As Boolean = False, _
                Optional bHorizontal As Boolean = False, _
                Optional LngMin As Long = -1, _
                Optional LngMax As Long = -1, _
                Optional ArraySwapped As Variant)
  On Error Resume Next
  Dim i As Long, J As Long, R As Long, v As Variant, t As Variant, s()
  If IsEmpty(ArrayIn) Then Exit Sub
  If VBA.InStr(TypeName(ArrayIn), "()") < 1 Then Exit Sub
  v = Empty
  If bHorizontal Then
    If LngMin = -1 Then LngMin = LBound(ArrayIn, 2)
    If LngMax = -1 Then LngMax = UBound(ArrayIn, 2)
    v = ArrayIn(lngIndex, (LngMin + LngMax) \ 2)
  Else
    If LngMin = -1 Then LngMin = LBound(ArrayIn, 1)
    If LngMax = -1 Then LngMax = UBound(ArrayIn, 1)
    v = ArrayIn((LngMin + LngMax) \ 2, lngIndex)
  End If

  If LngMin >= LngMax Then Exit Sub
  i = LngMin: J = LngMax
  Select Case True
  Case VBA.IsObject(v): i = LngMax: J = LngMin
  Case IsEmpty(v): i = LngMax: J = LngMin
  Case IsNull(v): i = LngMax: J = LngMin
  Case v = vbNullString: i = LngMax: J = LngMin
  Case VBA.VarType(v) = vbError: i = LngMax: J = LngMin
  Case VBA.VarType(v) > 17: i = LngMax: J = LngMin
  End Select
  If bHorizontal Then
    If bDescending Then
      While i <= J
        While ArrayIn(lngIndex, i) > v And i < LngMax: i = i + 1: Wend
        While v > ArrayIn(lngIndex, J) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
            t = ArrayIn(R, i)
            ArrayIn(R, i) = ArrayIn(R, J)
            ArrayIn(R, J) = t
          Next R
          i = i + 1: J = J - 1
        End If
      Wend
    Else
      While i <= J
        While ArrayIn(lngIndex, i) < v And i < LngMax: i = i + 1: Wend
        While v < ArrayIn(lngIndex, J) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
            t = ArrayIn(R, i)
            ArrayIn(R, i) = ArrayIn(R, J)
            ArrayIn(R, J) = t
          Next R
          i = i + 1: J = J - 1
        End If
      Wend
    End If
  Else
    If bDescending Then
      While i <= J
        While ArrayIn(i, lngIndex) > v And i < LngMax: i = i + 1: Wend
        While v > ArrayIn(J, lngIndex) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
            t = ArrayIn(i, R)
            ArrayIn(i, R) = ArrayIn(J, R)
            ArrayIn(J, R) = t
          Next R
          i = i + 1: J = J - 1
        End If
      Wend
    Else
      While i <= J
        While ArrayIn(i, lngIndex) < v And i < LngMax: i = i + 1: Wend
        While v < ArrayIn(J, lngIndex) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
            t = ArrayIn(i, R)
            ArrayIn(i, R) = ArrayIn(J, R)
            ArrayIn(J, R) = t
          Next R
          i = i + 1: J = J - 1
        End If
      Wend
    End If
  End If
  If (LngMin < J) Then Call ArrayQuickSort(ArrayIn, lngIndex, bDescending, bHorizontal, LngMin, J, ArraySwapped)
  If (i < LngMax) Then Call ArrayQuickSort(ArrayIn, lngIndex, bDescending, bHorizontal, i, LngMax, ArraySwapped)
End Sub
Sub ArrayQuickSort2(ByRef ArrayIn As Variant, _
                Optional lngIndex As Long = 0, _
                Optional bDescending As Boolean = False, _
                Optional bHorizontal As Boolean = False, _
                Optional LngMin As Long = -1, _
                Optional LngMax As Long = -1, _
                Optional ArraySwapped As Variant)
  On Error Resume Next
  Dim i As Long, J As Long, R As Long, c As Long, v As Variant, t As Variant, s()
  If IsEmpty(ArrayIn) Then Exit Sub
  If VBA.InStr(TypeName(ArrayIn), "()") < 1 Then Exit Sub
  v = Empty
  If bHorizontal Then
    c = LBound(ArrayIn, 2): R = UBound(ArrayIn, 2)
    If LngMin = -1 Then LngMin = c
    If LngMax = -1 Then LngMax = R
    v = ArrayIn(lngIndex, (LngMin + LngMax) \ 2)
  Else
    c = LBound(ArrayIn, 1): R = UBound(ArrayIn, 1)
    If LngMin = -1 Then LngMin = c
    If LngMax = -1 Then LngMax = R
    v = ArrayIn((LngMin + LngMax) \ 2, lngIndex)
  End If
  If VBA.InStr(TypeName(ArraySwapped), "()") < 1 Then
    ReDim s(c To R): For i = c To R: s(i) = i: Next
    ArraySwapped = s
  End If
  If LngMin >= LngMax Then Exit Sub
  i = LngMin: J = LngMax
  Select Case True
  Case VBA.IsObject(v): i = LngMax: J = LngMin
  Case IsEmpty(v): i = LngMax: J = LngMin
  Case IsNull(v): i = LngMax: J = LngMin
  Case v = vbNullString: i = LngMax: J = LngMin
  Case VBA.VarType(v) = vbError: i = LngMax: J = LngMin
  Case VBA.VarType(v) > 17: i = LngMax: J = LngMin
  End Select
  If bHorizontal Then
    If bDescending Then
      While i <= J
        While ArrayIn(lngIndex, i) > v And i < LngMax: i = i + 1: Wend
        While v > ArrayIn(lngIndex, J) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
            t = ArrayIn(R, i): ArrayIn(R, i) = ArrayIn(R, J): ArrayIn(R, J) = t
          Next R
          t = ArraySwapped(i): ArraySwapped(i) = ArraySwapped(J): ArraySwapped(J) = t
          i = i + 1: J = J - 1
        End If
      Wend
    Else
      While i <= J
        While ArrayIn(lngIndex, i) < v And i < LngMax: i = i + 1: Wend
        While v < ArrayIn(lngIndex, J) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
            t = ArrayIn(R, i): ArrayIn(R, i) = ArrayIn(R, J): ArrayIn(R, J) = t
          Next R
          t = ArraySwapped(i): ArraySwapped(i) = ArraySwapped(J): ArraySwapped(J) = t
          i = i + 1: J = J - 1
        End If
      Wend
    End If
  Else
    If bDescending Then
      While i <= J
        While ArrayIn(i, lngIndex) > v And i < LngMax: i = i + 1: Wend
        While v > ArrayIn(J, lngIndex) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
            t = ArrayIn(i, R): ArrayIn(i, R) = ArrayIn(J, R): ArrayIn(J, R) = t
          Next R
          t = ArraySwapped(i): ArraySwapped(i) = ArraySwapped(J): ArraySwapped(J) = t
          i = i + 1: J = J - 1
        End If
      Wend
    Else
      While i <= J
        While ArrayIn(i, lngIndex) < v And i < LngMax: i = i + 1: Wend
        While v < ArrayIn(J, lngIndex) And J > LngMin: J = J - 1: Wend
        If i <= J Then
          For R = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
            t = ArrayIn(i, R): ArrayIn(i, R) = ArrayIn(J, R): ArrayIn(J, R) = t
          Next R
          t = ArraySwapped(i): ArraySwapped(i) = ArraySwapped(J): ArraySwapped(J) = t
          i = i + 1: J = J - 1
        End If
      Wend
    End If
  End If
  If (LngMin < J) Then Call ArrayQuickSort(ArrayIn, lngIndex, bDescending, bHorizontal, LngMin, J, ArraySwapped)
  If (i < LngMax) Then Call ArrayQuickSort(ArrayIn, lngIndex, bDescending, bHorizontal, i, LngMax, ArraySwapped)
End Sub
Private Sub ArrayQuickSortV_test()
  Dim Arr, t As Double: t = Timer
  Arr = [F3:J7].value
  ArrayQuickSortV Arr, 1
  [F10:J14].value = Arr
  '----------------------------
  Arr = [F3:K8].value
  ArrayQuickSortV Arr, 1
  [F16:K21].value = Arr
  '----------------------------

  Arr = [F3:J7].value
  ArrayQuickSortV Arr, 1, True
  [F23:J27].value = Arr
  '----------------------------
  Arr = [F3:K8].value
  ArrayQuickSortV Arr, 1, True
  [F29:K34].value = Arr
  Debug.Print Round(Timer - t, 5)
End Sub
Sub ArrayQuickSortV(ByRef ArrayIn As Variant, _
                Optional lngColumn As Long = 0, _
                Optional bDescending As Boolean = False, _
                Optional LngMin& = -1, _
                Optional LngMax& = -1)
  On Error Resume Next
  Dim i&, J&
  Dim varMid As Variant, Tmp As Variant, lngColTemp&
  If IsEmpty(ArrayIn) Then Exit Sub
  If VBA.InStr(TypeName(ArrayIn), "()") < 1 Then Exit Sub
  If LngMin = -1 Then LngMin = LBound(ArrayIn, 1)
  If LngMax = -1 Then LngMax = UBound(ArrayIn, 1)
  ' no sorting required
  If LngMin >= LngMax Then Exit Sub
  i = LngMin: J = LngMax
  varMid = Empty
  varMid = ArrayIn((LngMin + LngMax) \ 2, lngColumn)
  Select Case True
  Case VBA.IsObject(varMid): i = LngMax: J = LngMin
  Case IsEmpty(varMid): i = LngMax: J = LngMin
  Case IsNull(varMid): i = LngMax: J = LngMin
  Case varMid = "": i = LngMax: J = LngMin
  Case VBA.VarType(varMid) = vbError: i = LngMax: J = LngMin
  Case VBA.VarType(varMid) > 17: i = LngMax: J = LngMin
  End Select
  If bDescending Then
    While i <= J
      While ArrayIn(i, lngColumn) > varMid And i < LngMax: i = i + 1: Wend
      While varMid > ArrayIn(J, lngColumn) And J > LngMin: J = J - 1: Wend
      If i <= J Then
        For lngColTemp = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
          Tmp = ArrayIn(i, lngColTemp)
          ArrayIn(i, lngColTemp) = ArrayIn(J, lngColTemp)
          ArrayIn(J, lngColTemp) = Tmp
        Next lngColTemp
        i = i + 1: J = J - 1
      End If
    Wend
  Else
    While i <= J
      While ArrayIn(i, lngColumn) < varMid And i < LngMax: i = i + 1: Wend
      While varMid < ArrayIn(J, lngColumn) And J > LngMin: J = J - 1: Wend
      If i <= J Then
        For lngColTemp = LBound(ArrayIn, 2) To UBound(ArrayIn, 2)
          Tmp = ArrayIn(i, lngColTemp)
          ArrayIn(i, lngColTemp) = ArrayIn(J, lngColTemp)
          ArrayIn(J, lngColTemp) = Tmp
        Next lngColTemp
        i = i + 1: J = J - 1
      End If
    Wend
  End If
  If (LngMin < J) Then Call ArrayQuickSortV(ArrayIn, lngColumn, bDescending, LngMin, J)
  If (i < LngMax) Then Call ArrayQuickSortV(ArrayIn, lngColumn, bDescending, i, LngMax)
End Sub
Sub ArrayQuickSortH(ByRef ArrayIn As Variant, _
                 Optional lngColumn& = 0, _
                 Optional bDescending As Boolean, _
                 Optional LngMin& = -1, _
                 Optional LngMax& = -1)
  On Error Resume Next
  Dim i&, J&
  Dim varMid As Variant, arrRowTemp As Variant
  Dim lngColTemp&
  If IsEmpty(ArrayIn) Then Exit Sub
  If VBA.InStr(TypeName(ArrayIn), "()") < 1 Then Exit Sub
  If LngMin = -1 Then LngMin = LBound(ArrayIn, 2)
  If LngMax = -1 Then LngMax = UBound(ArrayIn, 2)
  If LngMin >= LngMax Then Exit Sub
  i = LngMin: J = LngMax
  varMid = Empty
  varMid = ArrayIn(lngColumn, (LngMin + LngMax) \ 2)
  Select Case True
  Case VBA.IsObject(varMid): i = LngMax: J = LngMin
  Case IsEmpty(varMid): i = LngMax: J = LngMin
  Case IsNull(varMid): i = LngMax: J = LngMin
  Case varMid = "": i = LngMax: J = LngMin
  Case VBA.VarType(varMid) = vbError: i = LngMax: J = LngMin
  Case VBA.VarType(varMid) > 17: i = LngMax: J = LngMin
  End Select
  If bDescending Then
    While i <= J
      While ArrayIn(lngColumn, i) > varMid And i < LngMax: i = i + 1: Wend
      While varMid > ArrayIn(lngColumn, J) And J > LngMin: J = J - 1: Wend
      If i <= J Then
        ReDim arrRowTemp(LBound(ArrayIn, 1) To UBound(ArrayIn, 1))
        For lngColTemp = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
          arrRowTemp(lngColTemp) = ArrayIn(lngColTemp, i)
          ArrayIn(lngColTemp, i) = ArrayIn(lngColTemp, J)
          ArrayIn(lngColTemp, J) = arrRowTemp(lngColTemp)
        Next lngColTemp
        Erase arrRowTemp
        i = i + 1: J = J - 1
      End If
    Wend
  Else
    While i <= J
      While ArrayIn(lngColumn, i) < varMid And i < LngMax: i = i + 1: Wend
      While varMid < ArrayIn(lngColumn, J) And J > LngMin: J = J - 1: Wend
      If i <= J Then
        ReDim arrRowTemp(LBound(ArrayIn, 1) To UBound(ArrayIn, 1))
        For lngColTemp = LBound(ArrayIn, 1) To UBound(ArrayIn, 1)
          arrRowTemp(lngColTemp) = ArrayIn(lngColTemp, i)
          ArrayIn(lngColTemp, i) = ArrayIn(lngColTemp, J)
          ArrayIn(lngColTemp, J) = arrRowTemp(lngColTemp)
        Next lngColTemp
        Erase arrRowTemp
        i = i + 1: J = J - 1
      End If
    Wend
  End If
  If (LngMin < J) Then Call ArrayQuickSortH(ArrayIn, lngColumn, bDescending, LngMin, J)
  If (i < LngMax) Then Call ArrayQuickSortH(ArrayIn, lngColumn, bDescending, i, LngMax)
End Sub
Nhấp chuột vào đây để mở rộng...
Code có sort theo nhiều cột và sort tiếng Việt được không bạn
 
Upvote 0

File đính kèm

  • Danh so Thu tu_VD.xlsm
    20.5 KB · Đọc: 16
Lần chỉnh sửa cuối:
Upvote 0
Maika8008 đã viết:
Xếp được 2 cột nhưng tiếng Việt thì không được. VD chữ Đ bị xếp xuống dưới cùng.
Bài đã được tự động gộp:


File ví dụ ,,,,,,,,,,,,,,,
Nhấp chuột vào đây để mở rộng...
Code của bạn ngày càng hay /-*+/
Thêm tham số sort từ nhỏ tới lớn hoặc ngược lại sẽ khá đầy đủ tùy chọn
Cách so sánh trực tiếp rất khó viết code sort tiếng Việt, dùng sort của array list như cách bạn @befaint ổn hơn và dể viết code hơn
 
Upvote 0
Maika8008 đã viết:
Xếp được 2 cột nhưng tiếng Việt thì không được. VD chữ Đ bị xếp xuống dưới cùng.
Bài đã được tự động gộp:


File ví dụ
Maika8008 đã viết:
Xếp được 2 cột nhưng tiếng Việt thì không được. VD chữ Đ bị xếp xuống dưới cùng.
Bài đã được tự động gộp:


File ví dụ ,,,,,,,,,,,,,,,
Nhấp chuột vào đây để mở rộng...
Anh oi, cái này co
Nhấp chuột vào đây để mở rộng...

Maika8008 đã viết:
Xếp được 2 cột nhưng tiếng Việt thì không được. VD chữ Đ bị xếp xuống dưới cùng.
Bài đã được tự động gộp:


File ví dụ ,,,,,,,,,,,,,,,
Nhấp chuột vào đây để mở rộng...
Anh oi, cái này có sort dữ liệu được theo dòng không hở anh?
 
Upvote 0
Maika8008 đã viết:
Nghĩa là sao, tôi không hiểu? Bạn đã bao giờ dùng chức năng sort của Excel chưa, thứ này sort y như vậy?
Nhấp chuột vào đây để mở rộng...
Em cảm ơn anh ạ
Anh lấy ví dụ cho em sort theo hàng với anh nhé!
Và hàm có nhiều tham số quá, anh giải thiích từng tham số cho em và mọi người hiểu với.
 
Upvote 0
hongphuong1997 đã viết:
Em cảm ơn anh ạ
Anh lấy ví dụ cho em sort theo hàng với anh nhé!
Và hàm có nhiều tham số quá, anh giải thiích từng tham số cho em và mọi người hiểu với.
Nhấp chuột vào đây để mở rộng...
File ví dụ ở bài #9
Cú pháp ở bài #4

Bạn không chịu đọc, không chịu làm gì trơn!
 
Upvote 0
HieuCD đã viết:
Code có sort theo nhiều cột và sort tiếng Việt được không bạn
Nhấp chuột vào đây để mở rộng...
Định nghĩa sort nhiều cột là như thế nào bác HieuCD?
Em chỉ biết sort nhiều tầng.
Cột sort các dữ liệu trùng thì sort cột thứ 2 nó là tầng sort thứ 2, cứ thế cho các tầng mong muốn.

Với thuật toán quick sort ở trên thì muốn sort bao nhiều tầng, không có gì khó.


Còn sort tiếng Việt, thêm các ràng buộc sử dụng Hàm StrComp là được.

Bác có thể tham khảo code tại bài viết:
giaiphapexcel.com

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

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 CỘT) Hàm VSORT và Thủ tục VSORTING - Sắp xếp dọc Hàm HSORT và Thủ tục HSORTING - Sắp xếp ngang Mục tiêu đạt được: Sắp xếp cả mảng ngang...
giaiphapexcel.com giaiphapexcel.com
 
Lần chỉnh sửa cuối:
Upvote 0
hongphuong1997 đã viết:
Khổ quá anh oi, thật sự đầu óc em ngu ơi là ngu
Nhưng mờ bài 4 và 9 em vẫn chưa hiểu được mà.
Nhấp chuột vào đây để mở rộng...
Trong file ví dụ đã có sub test hàm. Xem trong đó thì biết cú pháp, muốn chạy thì bấm là chạy.

Mà việc dùng hàm (chứ không phải thủ tục - Sub) để sắp xếp trong mảng là phục vụ mục đích chuyển tiếp khi code trước đó đã ra kết quả là 1 mảng nên cần sắp xếp để làm tiếp để đến kết quả cuối cùng.

Đa số công việc bình thường thì cứ dán mảng lên sheet rồi dùng lệnh của VBA Excel (ghi macro trình tự sort ra là có) để sắp xếp là hết chuyện.
 
Lần chỉnh sửa cuối:
Upvote 0
Cập nhật bài #1:
1. Thêm tùy chọn sắp xếp giảm/tăng dần: Cảm ơn gợi ý của @HieuCD cho tùy chọn này.
2. Đã sắp xếp được tiếng Việt; Cảm ơn @HeSanbi về gợi ý áp dụng hàm StrComp tại bài #15.

Hàm sắp xếp mảng này có 1 chỗ chưa ổn với các trường số có độ dài khác nhau ở các dòng. Ví dụ 1, 2, 10, 11, 20, 30 thì bị xếp thành 1, 10, 11, 2, 20, 30 (vì code xem đây là text và sắp theo kiểu text chứ không phải sắp theo number). Bạn nào biết chỉ cho tôi cách để hoàn thiện chỗ này chút.

Bài #1 không được phép sửa nên tôi đăng code ở đây:
Rich (BB code): 
Function QuickSortArrayF(ByRef SortArray As Variant, Optional Order As Boolean = True, Optional lngMin As Long = -1, Optional lngMax As Long = -1, Optional lngColumn As Long = 0)
    On Error Resume Next

    'Sort a 2-Dimensional array

    ' SampleUsage: sort arrData by the contents of column 3
    '
    '   QuickSortArray arrData, , , 3

    '
    'Posted by Jim Rech 10/20/98 Excel.Programming

    'Modifications, Nigel Heffernan:

    '       ' Escape failed comparison with empty variant
    '       ' Defensive coding: check inputs

    Dim i As Long
    Dim j As Long
    Dim varMid As Variant
    Dim arrRowTemp As Variant
    Dim lngColTemp As Long

    If IsEmpty(SortArray) Then
        Exit Function
    End If
    If InStr(TypeName(SortArray), "()") < 1 Then  'IsArray() is somewhat broken: Look for brackets in the type name
        Exit Function
    End If
    If lngMin = -1 Then
        lngMin = LBound(SortArray, 1)
    End If
    If lngMax = -1 Then
        lngMax = UBound(SortArray, 1)
    End If
    If lngMin >= lngMax Then    ' no sorting required
        Exit Function
    End If

    i = lngMin
    j = lngMax
      
    varMid = Empty
    varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)

    ' We  send 'Empty' and invalid data items to the end of the list:
    If IsObject(varMid) Then  ' note that we don't check isObject(SortArray(n)) - varMid *might* pick up a valid default member or property
        i = lngMax
        j = lngMin
    ElseIf IsEmpty(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf IsNull(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf varMid = "" 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 Order Then
        While i <= j
            While (StrComp(SortArray(i, lngColumn), varMid, 1) = -1 Or (SortArray(i, lngColumn) < varMid) And StrComp(SortArray(i, lngColumn), varMid, 1) = 0) And i < lngMax
                i = i + 1
            Wend
            While (StrComp(varMid, SortArray(j, lngColumn), 1) = -1 Or (varMid < SortArray(j, lngColumn)) And StrComp(varMid, SortArray(j, lngColumn), 1) = 0) And j > lngMin
                j = j - 1
            Wend
            If i <= j Then
                'Hoan doi cac dong
                ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))
                For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)
                    arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)
                    SortArray(i, lngColTemp) = SortArray(j, lngColTemp)
                    SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)
                Next
                Erase arrRowTemp
                i = i + 1
                j = j - 1
            End If
        Wend
    Else
        While i <= j
            While (StrComp(varMid, SortArray(i, lngColumn), 1) = -1 Or (SortArray(i, lngColumn) > varMid) And StrComp(varMid, SortArray(i, lngColumn), 1) = 0) And i < lngMax
                i = i + 1
            Wend
            While (StrComp(SortArray(j, lngColumn), varMid, 1) = -1 Or (varMid > SortArray(j, lngColumn)) And StrComp(SortArray(j, lngColumn), varMid, 1) = 0) And j > lngMin
                j = j - 1
            Wend
            'Hoan doi cac dong
            If i <= j Then
                ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))
                For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)
                    arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)
                    SortArray(i, lngColTemp) = SortArray(j, lngColTemp)
                    SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)
                Next
                Erase arrRowTemp
                i = i + 1
                j = j - 1
            End If
        Wend
    End If
'---------------------------
    If (lngMin < j) Then Call QuickSortArrayF(SortArray, Order, lngMin, j, lngColumn)
    If (i < lngMax) Then Call QuickSortArrayF(SortArray, Order, i, lngMax, lngColumn)
    
    QuickSortArrayF = SortArray
End Function

Function QuickSortArrayF2(ByRef SortArray As Variant, Optional Order As Boolean = True, Optional Order2 As Boolean = True, Optional lngMin As Long = -1, Optional lngMax As Long = -1, Optional lngColumn As Long = 0, Optional lngColumn2 As Long = 0)
Dim SortArr As Variant
Dim i As Long, j As Long, k As Long, D As Long, r As Long
    If lngColumn = 0 Then lngColumn = 1
    SortArray = QuickSortArrayF(SortArray, Order, , , lngColumn)
    ReDim TempArray(1 To UBound(SortArray, 1), 1 To UBound(SortArray, 2))
    For i = LBound(SortArray, 1) To UBound(SortArray, 1)
        k = k + 1
        On Error Resume Next
        If SortArray(i, lngColumn) <> SortArray(i + 1, lngColumn) Then
            If Err.Number = 9 Then
                On Error GoTo 0
                GoTo Sort
            End If
Sort:       If k > 1 Then
                ReDim SortArr(1 To k, 1 To UBound(SortArray, 2))
                For r = 1 To k
                    For j = LBound(SortArray, 2) To UBound(SortArray, 2)
                        SortArr(r, j) = SortArray(i - k + r, j)
                    Next
                Next
                SortArr = QuickSortArrayF(SortArr, Order2, , , lngColumn2)
                For D = i - k + 1 To i
                    For j = LBound(SortArray, 2) To UBound(SortArray, 2)
                        SortArray(D, j) = SortArr(D + k - i, j)
                    Next
                Next
                k = 0
            Else
                k = 0
            End If
        End If
    Next
    QuickSortArrayF2 = SortArray
End Function
 
Upvote 0
Hôm qua tính nói hàm của bạn bị đụng hàng "Siêu" rồi, không còn cửa. :p
Nhưng hôm nay, cái hàm kia nó tự động khiêm nhường, gỡ mất danh hiệu "sụp-pơ" rồi. Coi như hiệp đầu chưa có gì. :victory:
 
Upvote 0
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

nguyenphuochien166
Cách Vlookup hoặc cách lấy thông tin dữ liệu có dấu mũ lũy thừa?
    • Cười
Trả lời
3
Đọc
37
DeTong
D
C
Chia sẻ: Kết quả xổ số Keno
    • Thích
Trả lời
5
Đọc
157
DeTong
D
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
2
Trả lời
24
Đọc
462
SA_DQ
SA_DQ
B
Lọc dữ liệu trùng, đếm số lần, tự tô màu theo điều kiện.
Trả lời
3
Đọc
83
batista911
B
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
12
Đọc
212
ptm0412
ptm0412
C
Công thức tự nhập liệu số lượng nhập khi bị âm
Trả lời
1
Đọc
70
hoangtuaotrang_hp_vn
H
kimtanmap
  • Question
Nhờ viết code VBA Macro lập lại.
Trả lời
5
Đọc
130
kimtanmap
kimtanmap
dung09031989
Xin giúp công thức tô màu các ô phía sau khi kế hoạch đặt hàng thiếu so với tồn kho.?
Trả lời
1
Đọc
67
hoangtuaotrang_hp_vn
H
huynhnhu1234
Tìm giá vé máy bay một chiều và khứ hồi
Trả lời
0
Đọc
38
huynhnhu1234
huynhnhu1234
V
[Nhờ giúp đỡ] Cách tìm thời gian bị trùng trong excel ở nhiều thời gian khác nhau
Trả lời
7
Đọc
121
tranvansau278
T
N
Hàm tìm giá trị theo giờ vào - ra
Trả lời
6
Đọc
111
Nguyễn Linh hn94
N
zarra
Cần giúp tạo form in mã vạch cho vật tư theo SL cụ thể.
Trả lời
4
Đọc
154
zarra
zarra
Nguyễn Duy Tuân
  • Question
Chia sẻ ControlForOffice - Bộ công cụ điều khiển Office/Excel
    • Thích
6 7 8
Trả lời
148
Đọc
95K
leminhksvl
L
HeSanbi
  • Question
Lỗi VBA: Cài đặt thông số ForceVBALoadFromSource trong Registry để VBA biên dịch không bị lỗi
    • Cảm ơn
    • Thích
Trả lời
5
Đọc
288
anhdepjai
A
H
Hàm đếm số ngày thứ bảy và chủ nhật trong một khoảng thời gian
Trả lời
18
Đọc
20K
DeTong
D
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
11 12 13
Trả lời
245
Đọc
13K
Hoàng Trọng Hữu
Hoàng Trọng Hữu
D
  • Question
Xin cách sắp xếp dữ liệu theo thứ tự không làm hỏng link
Trả lời
7
Đọc
300
cantl
C
N
Giúp sửa mã code
Trả lời
16
Đọc
279
ptm0412
ptm0412
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
1
Đọc
62
hoangminhtien
hoangminhtien
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
Trả lời
0
Đọc
197
GPE-Trợ Lý
GPE-Trợ Lý
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom