Hàm sắp xếp mảng VBA?

Question 1

Tôi đang tìm cách triển khai sắp xếp hợp lý cho các mảng trong VBA. Quicksort sẽ được ưu tiên hơn. Hoặc bất kỳ thuật toán sắp xếp nào khác ngoài bong bóng hoặc hợp nhất sẽ đủ.

Xin lưu ý rằng điều này làm việc với MS Project 2003, vì vậy nên tránh bất kỳ hàm gốc Excel nào và bất kỳ thứ gì liên quan đến .net.

Question 2

~~Hãy xem ở đây :~~
Chỉnh sửa: Nguồn tham khảo (allexperts.com) đã đóng cửa, nhưng đây là các nhận xét của tác giả có liên quan :

Có rất nhiều thuật toán có sẵn trên web để phân loại. Linh hoạt nhất và thường là nhanh nhất là thuật toán Quicksort . Dưới đây là một chức năng cho nó.

Gọi nó đơn giản bằng cách truyền một mảng giá trị (chuỗi hoặc số; không quan trọng) với Ranh giới mảng dưới (thông thường 0) và Ranh giới mảng trên (ví dụ UBound(myArray):)

Ví dụ :Call QuickSort(myArray, 0, UBound(myArray))

Khi nó hoàn thành, myArraysẽ được sắp xếp và bạn có thể làm những gì bạn muốn với nó.
_{(Nguồn: archive.org )}

Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long

  tmpLow = inLow
  tmpHi = inHi

  pivot = vArray((inLow + inHi) \ 2)

  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend

     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend

     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend

  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

Lưu ý rằng điều này chỉ hoạt động với mảng một chiều (còn gọi là "bình thường"?). (Có một mảng QuickSort đa chiều đang hoạt động ở đây .)

Question 3

Tôi đã chuyển đổi thuật toán 'sắp xếp nhanh chóng nhanh chóng' thành VBA, nếu có ai khác muốn.

Tôi đã tối ưu hóa nó để chạy trên một mảng Int / Longs nhưng sẽ đơn giản để chuyển đổi nó thành một mảng hoạt động trên các phần tử so sánh tùy ý.

Private Sub QuickSort(ByRef a() As Long, ByVal l As Long, ByVal r As Long)
    Dim M As Long, i As Long, j As Long, v As Long
    M = 4

    If ((r - l) > M) Then
        i = (r + l) / 2
        If (a(l) > a(i)) Then swap a, l, i '// Tri-Median Methode!'
        If (a(l) > a(r)) Then swap a, l, r
        If (a(i) > a(r)) Then swap a, i, r

        j = r - 1
        swap a, i, j
        i = l
        v = a(j)
        Do
            Do: i = i + 1: Loop While (a(i) < v)
            Do: j = j - 1: Loop While (a(j) > v)
            If (j < i) Then Exit Do
            swap a, i, j
        Loop
        swap a, i, r - 1
        QuickSort a, l, j
        QuickSort a, i + 1, r
    End If
End Sub

Private Sub swap(ByRef a() As Long, ByVal i As Long, ByVal j As Long)
    Dim T As Long
    T = a(i)
    a(i) = a(j)
    a(j) = T
End Sub

Private Sub InsertionSort(ByRef a(), ByVal lo0 As Long, ByVal hi0 As Long)
    Dim i As Long, j As Long, v As Long

    For i = lo0 + 1 To hi0
        v = a(i)
        j = i
        Do While j > lo0
            If Not a(j - 1) > v Then Exit Do
            a(j) = a(j - 1)
            j = j - 1
        Loop
        a(j) = v
    Next i
End Sub

Public Sub sort(ByRef a() As Long)
    QuickSort a, LBound(a), UBound(a)
    InsertionSort a, LBound(a), UBound(a)
End Sub

Question 4

Giải thích bằng tiếng Đức nhưng mã là một triển khai tại chỗ đã được thử nghiệm tốt:

Private Sub QuickSort(ByRef Field() As String, ByVal LB As Long, ByVal UB As Long)
    Dim P1 As Long, P2 As Long, Ref As String, TEMP As String

    P1 = LB
    P2 = UB
    Ref = Field((P1 + P2) / 2)

    Do
        Do While (Field(P1) < Ref)
            P1 = P1 + 1
        Loop

        Do While (Field(P2) > Ref)
            P2 = P2 - 1
        Loop

        If P1 <= P2 Then
            TEMP = Field(P1)
            Field(P1) = Field(P2)
            Field(P2) = TEMP

            P1 = P1 + 1
            P2 = P2 - 1
        End If
    Loop Until (P1 > P2)

    If LB < P2 Then Call QuickSort(Field, LB, P2)
    If P1 < UB Then Call QuickSort(Field, P1, UB)
End Sub

Được mời như thế này:

Call QuickSort(MyArray, LBound(MyArray), UBound(MyArray))

Question 5

Dim arr As Object
Dim InputArray

'Creating a array list
Set arr = CreateObject("System.Collections.ArrayList")

'String
InputArray = Array("d", "c", "b", "a", "f", "e", "g")

'number
'InputArray = Array(6, 5, 3, 4, 2, 1)

' adding the elements in the array to array_list
For Each element In InputArray
    arr.Add element
Next

'sorting happens
arr.Sort

'Converting ArrayList to an array
'so now a sorted array of elements is stored in the array sorted_array.

sorted_array = arr.toarray

Question 6

Số tự nhiên (chuỗi) Sắp xếp nhanh

Chỉ để dồn vào chủ đề. Thông thường, nếu bạn sắp xếp các chuỗi bằng các số, bạn sẽ nhận được một thứ như sau:

    Text1
    Text10
    Text100
    Text11
    Text2
    Text20

Nhưng bạn thực sự muốn nó nhận ra các giá trị số và được sắp xếp như

    Text1
    Text2
    Text10
    Text11
    Text20
    Text100

Đây là cách thực hiện ...

Ghi chú:

Tôi đã đánh cắp Sắp xếp nhanh từ internet cách đây khá lâu, không biết bây giờ ở đâu ...
Tôi cũng đã dịch hàm CompareNaturalNum được viết bằng C từ internet.
Sự khác biệt so với các loại Q khác: Tôi không hoán đổi các giá trị nếu BottomTemp = TopTemp

Số tự nhiên Sắp xếp nhanh

Public Sub QuickSortNaturalNum(strArray() As String, intBottom As Integer, intTop As Integer)
Dim strPivot As String, strTemp As String
Dim intBottomTemp As Integer, intTopTemp As Integer

    intBottomTemp = intBottom
    intTopTemp = intTop

    strPivot = strArray((intBottom + intTop) \ 2)

    Do While (intBottomTemp <= intTopTemp)
        ' < comparison of the values is a descending sort
        Do While (CompareNaturalNum(strArray(intBottomTemp), strPivot) < 0 And intBottomTemp < intTop)
            intBottomTemp = intBottomTemp + 1
        Loop
        Do While (CompareNaturalNum(strPivot, strArray(intTopTemp)) < 0 And intTopTemp > intBottom) '
            intTopTemp = intTopTemp - 1
        Loop
        If intBottomTemp < intTopTemp Then
            strTemp = strArray(intBottomTemp)
            strArray(intBottomTemp) = strArray(intTopTemp)
            strArray(intTopTemp) = strTemp
        End If
        If intBottomTemp <= intTopTemp Then
            intBottomTemp = intBottomTemp + 1
            intTopTemp = intTopTemp - 1
        End If
    Loop

    'the function calls itself until everything is in good order
    If (intBottom < intTopTemp) Then QuickSortNaturalNum strArray, intBottom, intTopTemp
    If (intBottomTemp < intTop) Then QuickSortNaturalNum strArray, intBottomTemp, intTop
End Sub

So sánh số tự nhiên (Được sử dụng trong Sắp xếp nhanh)

Function CompareNaturalNum(string1 As Variant, string2 As Variant) As Integer
'string1 is less than string2 -1
'string1 is equal to string2 0
'string1 is greater than string2 1
Dim n1 As Long, n2 As Long
Dim iPosOrig1 As Integer, iPosOrig2 As Integer
Dim iPos1 As Integer, iPos2 As Integer
Dim nOffset1 As Integer, nOffset2 As Integer

    If Not (IsNull(string1) Or IsNull(string2)) Then
        iPos1 = 1
        iPos2 = 1
        Do While iPos1 <= Len(string1)
            If iPos2 > Len(string2) Then
                CompareNaturalNum = 1
                Exit Function
            End If
            If isDigit(string1, iPos1) Then
                If Not isDigit(string2, iPos2) Then
                    CompareNaturalNum = -1
                    Exit Function
                End If
                iPosOrig1 = iPos1
                iPosOrig2 = iPos2
                Do While isDigit(string1, iPos1)
                    iPos1 = iPos1 + 1
                Loop

                Do While isDigit(string2, iPos2)
                    iPos2 = iPos2 + 1
                Loop

                nOffset1 = (iPos1 - iPosOrig1)
                nOffset2 = (iPos2 - iPosOrig2)

                n1 = Val(Mid(string1, iPosOrig1, nOffset1))
                n2 = Val(Mid(string2, iPosOrig2, nOffset2))

                If (n1 < n2) Then
                    CompareNaturalNum = -1
                    Exit Function
                ElseIf (n1 > n2) Then
                    CompareNaturalNum = 1
                    Exit Function
                End If

                ' front padded zeros (put 01 before 1)
                If (n1 = n2) Then
                    If (nOffset1 > nOffset2) Then
                        CompareNaturalNum = -1
                        Exit Function
                    ElseIf (nOffset1 < nOffset2) Then
                        CompareNaturalNum = 1
                        Exit Function
                    End If
                End If
            ElseIf isDigit(string2, iPos2) Then
                CompareNaturalNum = 1
                Exit Function
            Else
                If (Mid(string1, iPos1, 1) < Mid(string2, iPos2, 1)) Then
                    CompareNaturalNum = -1
                    Exit Function
                ElseIf (Mid(string1, iPos1, 1) > Mid(string2, iPos2, 1)) Then
                    CompareNaturalNum = 1
                    Exit Function
                End If

                iPos1 = iPos1 + 1
                iPos2 = iPos2 + 1
            End If
        Loop
        ' Everything was the same so far, check if Len(string2) > Len(String1)
        ' If so, then string1 < string2
        If Len(string2) > Len(string1) Then
            CompareNaturalNum = -1
            Exit Function
        End If
    Else
        If IsNull(string1) And Not IsNull(string2) Then
            CompareNaturalNum = -1
            Exit Function
        ElseIf IsNull(string1) And IsNull(string2) Then
            CompareNaturalNum = 0
            Exit Function
        ElseIf Not IsNull(string1) And IsNull(string2) Then
            CompareNaturalNum = 1
            Exit Function
        End If
    End If
End Function

isDigit (Được sử dụng trong CompareNaturalNum)

Function isDigit(ByVal str As String, pos As Integer) As Boolean
Dim iCode As Integer
    If pos <= Len(str) Then
        iCode = Asc(Mid(str, pos, 1))
        If iCode >= 48 And iCode <= 57 Then isDigit = True
    End If
End Function

Question 7

Tôi đã đăng một số mã để trả lời cho một câu hỏi liên quan trên StackOverflow:

Sắp xếp mảng nhiều thứ nguyên trong VBA

Các mẫu mã trong chủ đề đó bao gồm:

Một mảng vectơ Quicksort;
Một mảng nhiều cột QuickSort;
Một BubbleSort.

Quicksort được tối ưu hóa của Alain rất sáng sủa: Tôi vừa thực hiện một phép tách và đệ quy cơ bản, nhưng mẫu mã ở trên có chức năng 'gating' giúp cắt giảm các so sánh dư thừa của các giá trị trùng lặp. Mặt khác, tôi viết mã cho Excel và có thêm một chút về cách mã hóa phòng thủ - hãy cảnh báo, bạn sẽ cần nó nếu mảng của bạn chứa biến thể 'Empty ()' nguy hiểm, sẽ phá vỡ While .. Wend các toán tử so sánh và bẫy mã của bạn trong một vòng lặp vô hạn.

Lưu ý rằng thuật toán nhanh - và bất kỳ thuật toán đệ quy nào - có thể lấp đầy ngăn xếp và làm hỏng Excel. Nếu mảng của bạn có ít hơn 1024 thành viên, tôi sẽ sử dụng một BubbleSort thô sơ.

Public Sub QuickSortArray (ByRef SortArray As Variant, _
                                Tùy chọn lngMin As Long = -1, _ 
                                Tùy chọn lngMax As Long = -1, _ 
                                Tùy chọn lngColumn As Long = 0)
Khi có lỗi Tiếp tục tiếp theo 

'Sắp xếp mảng 2 chiều

'Cách sử dụng mẫu: sắp xếp arrData theo nội dung của cột 3
'
'QuickSortArray arrData,,, 3

'
'Được đăng bởi Jim Rech 10/20/98 Excel.
 
Sửa đổi ', Nigel Heffernan:

'' So sánh thoát không thành công với biến thể trống
'' Mã hóa phòng thủ: kiểm tra đầu vào

Dim i As Long
Dim j As Long
Dim varMid As Variant
Dim arrRowTemp làm biến thể
Dim lngColTemp As Long


 Nếu IsEmpty (SortArray) Thì
     Thoát Sub
 Kết thúc nếu

 Nếu InStr (TypeName (SortArray), "()") <1 thì 'IsArray () hơi bị hỏng: Tìm dấu ngoặc trong tên kiểu
     Thoát Sub
 Kết thúc nếu

 Nếu lngMin = -1 Thì
     lngMin = LBound (SortArray, 1)
 Kết thúc nếu
 
 Nếu lngMax = -1 Thì
     lngMax = UBound (SortArray, 1)
 Kết thúc nếu
 
 If lngMin> = lngMax Then 'không cần phân loại
     Thoát Sub
 Kết thúc nếu


 i = lngMin
 j = lngMax

 varMid = Rỗng
 varMid = SortArray ((lngMin + lngMax) \ 2, lngColumn)

 'Chúng tôi gửi các mục dữ liệu' Trống rỗng 'và không hợp lệ đến cuối danh sách:
 If IsObject (varMid) Then 'lưu ý rằng chúng tôi không kiểm tra isObject (SortArray (n)) - varMid might chọn một thành viên hoặc thuộc tính mặc định hợp lệ
     i = lngMax
     j = lngMin
 ElseIf IsEmpty (varMid) Sau đó
     i = lngMax
     j = lngMin
 ElseIf IsNull (varMid) Sau đó
     i = lngMax
     j = lngMin
 ElseIf varMid = "" Sau đó
     i = lngMax
     j = lngMin
 ElseIf varType (varMid) = vbError Sau đó
     i = lngMax
     j = lngMin
 ElseIf varType (varMid)> 17 Sau đó
     i = lngMax
     j = lngMin
 Kết thúc Nếu 


 Trong khi Tôi <= j

     Trong khi SortArray (i, lngColumn) <varMid And i <lngMax
         i = i + 1
     Wend

     Trong khi varMid <SortArray (j, lngColumn) Và j> lngMin
         j = j - 1
     Wend 


     If i <= j Then

         'Hoán đổi các hàng
         ReDim arrRowTemp (LBound (SortArray, 2) Tới UBound (SortArray, 2))
         Đối với lngColTemp = LBound (SortArray, 2) Tới UBound (SortArray, 2)
             arrRowTemp (lngColTemp) = SortArray (i, lngColTemp)
             SortArray (i, lngColTemp) = SortArray (j, lngColTemp)
             SortArray (j, lngColTemp) = arrRowTemp (lngColTemp)
         Tiếp theo lngColTemp
         Xóa arrRowTemp

         i = i + 1
         j = j - 1 

     End If 


 Wend

 If (lngMin <j) Sau đó gọi QuickSortArray (SortArray, lngMin, j, lngColumn)
 If (i <lngMax) Sau đó gọi QuickSortArray (SortArray, i, lngMax, lngColumn) 

 
End Sub

Question 8

Bạn không muốn một giải pháp dựa trên Excel nhưng vì hôm nay tôi gặp vấn đề tương tự và muốn thử nghiệm bằng các hàm Ứng dụng Office khác, nên tôi đã viết hàm dưới đây.

Hạn chế:

Mảng 2 chiều;
tối đa 3 cột làm khóa sắp xếp;
phụ thuộc vào Excel;

Đã thử nghiệm gọi Excel 2010 từ Visio 2010

Option Base 1


Private Function sort_array_2D_excel(array_2D, array_sortkeys, Optional array_sortorders, Optional tag_header As String = "Guess", Optional tag_matchcase As String = "False")

'   Dependencies: Excel; Tools > References > Microsoft Excel [Version] Object Library

    Dim excel_application As Excel.Application
    Dim excel_workbook As Excel.Workbook
    Dim excel_worksheet As Excel.Worksheet

    Set excel_application = CreateObject("Excel.Application")

    excel_application.Visible = True
    excel_application.ScreenUpdating = False
    excel_application.WindowState = xlNormal

    Set excel_workbook = excel_application.Workbooks.Add
    excel_workbook.Activate

    Set excel_worksheet = excel_workbook.Worksheets.Add
    excel_worksheet.Activate
    excel_worksheet.Visible = xlSheetVisible

    Dim excel_range As Excel.Range
    Set excel_range = excel_worksheet.Range("A1").Resize(UBound(array_2D, 1) - LBound(array_2D, 1) + 1, UBound(array_2D, 2) - LBound(array_2D, 2) + 1)
    excel_range = array_2D


    For i_sortkey = LBound(array_sortkeys) To UBound(array_sortkeys)

        If IsNumeric(array_sortkeys(i_sortkey)) Then
            sortkey_range = Chr(array_sortkeys(i_sortkey) + 65 - 1) & "1"
            Set array_sortkeys(i_sortkey) = excel_worksheet.Range(sortkey_range)

        Else
            MsgBox "Error in sortkey parameter:" & vbLf & "array_sortkeys(" & i_sortkey & ") = " & array_sortkeys(i_sortkey) & vbLf & "Terminating..."
            End

        End If

    Next i_sortkey


    For i_sortorder = LBound(array_sortorders) To UBound(array_sortorders)
        Select Case LCase(array_sortorders(i_sortorder))
            Case "asc"
                array_sortorders(i_sortorder) = XlSortOrder.xlAscending
            Case "desc"
                array_sortorders(i_sortorder) = XlSortOrder.xlDescending
            Case Else
                array_sortorders(i_sortorder) = XlSortOrder.xlAscending
        End Select
    Next i_sortorder

    Select Case LCase(tag_header)
        Case "yes"
            tag_header = Excel.xlYes
        Case "no"
            tag_header = Excel.xlNo
        Case "guess"
            tag_header = Excel.xlGuess
        Case Else
            tag_header = Excel.xlGuess
    End Select

    Select Case LCase(tag_matchcase)
        Case "true"
            tag_matchcase = True
        Case "false"
            tag_matchcase = False
        Case Else
            tag_matchcase = False
    End Select


    Select Case (UBound(array_sortkeys) - LBound(array_sortkeys) + 1)
        Case 1
            Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Header:=tag_header, MatchCase:=tag_matchcase)
        Case 2
            Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Header:=tag_header, MatchCase:=tag_matchcase)
        Case 3
            Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Key3:=array_sortkeys(3), Order3:=array_sortorders(3), Header:=tag_header, MatchCase:=tag_matchcase)
        Case Else
            MsgBox "Error in sortkey parameter:" & vbLf & "Maximum number of sort columns is 3!" & vbLf & "Currently passed: " & (UBound(array_sortkeys) - LBound(array_sortkeys) + 1)
            End
    End Select


    For i_row = 1 To excel_range.Rows.Count

        For i_column = 1 To excel_range.Columns.Count

            array_2D(i_row, i_column) = excel_range(i_row, i_column)

        Next i_column

    Next i_row


    excel_workbook.Close False
    excel_application.Quit

    Set excel_worksheet = Nothing
    Set excel_workbook = Nothing
    Set excel_application = Nothing


    sort_array_2D_excel = array_2D


End Function

Đây là một ví dụ về cách kiểm tra chức năng:

Private Sub test_sort()

    array_unsorted = dim_sort_array()

    Call msgbox_array(array_unsorted)

    array_sorted = sort_array_2D_excel(array_unsorted, Array(2, 1, 3), Array("desc", "", "asdas"), "yes", "False")

    Call msgbox_array(array_sorted)

End Sub


Private Function dim_sort_array()

    Dim array_unsorted(1 To 5, 1 To 3) As String

    i_row = 0

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "Column1": array_unsorted(i_row, 2) = "Column2": array_unsorted(i_row, 3) = "Column3"

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "OR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "XOR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "NOT": array_unsorted(i_row, 2) = "B": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "AND": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    dim_sort_array = array_unsorted

End Function


Sub msgbox_array(array_2D, Optional string_info As String = "2D array content:")

    msgbox_string = string_info & vbLf

    For i_row = LBound(array_2D, 1) To UBound(array_2D, 1)

        msgbox_string = msgbox_string & vbLf & i_row & vbTab

        For i_column = LBound(array_2D, 2) To UBound(array_2D, 2)

            msgbox_string = msgbox_string & array_2D(i_row, i_column) & vbTab

        Next i_column

    Next i_row

    MsgBox msgbox_string

End Sub

Nếu ai đó kiểm tra điều này bằng cách sử dụng các phiên bản office khác, vui lòng đăng ở đây nếu có bất kỳ vấn đề nào.

Question 9

Tôi tự hỏi bạn sẽ nói gì về mã sắp xếp mảng này. Nó nhanh chóng để thực hiện và thực hiện công việc ... chưa thử nghiệm cho các mảng lớn. Nó hoạt động đối với mảng một chiều, đối với các giá trị bổ sung đa chiều, ma trận vị trí lại sẽ cần được xây dựng (với một kích thước nhỏ hơn mảng ban đầu).

       For AR1 = LBound(eArray, 1) To UBound(eArray, 1)
            eValue = eArray(AR1)
            For AR2 = LBound(eArray, 1) To UBound(eArray, 1)
                If eArray(AR2) < eValue Then
                    eArray(AR1) = eArray(AR2)
                    eArray(AR2) = eValue
                    eValue = eArray(AR1)
                End If
            Next AR2
        Next AR1

Question 10

Tôi nghĩ rằng mã của tôi (đã được thử nghiệm) có tính "giáo dục" nhiều hơn, giả sử càng đơn giản càng tốt .

Option Base 1

'Function to sort an array decscending
Function SORT(Rango As Range) As Variant
    Dim check As Boolean
    check = True
    If IsNull(Rango) Then
        check = False
    End If
    If check Then
        Application.Volatile
        Dim x() As Variant, n As Double, m As Double, i As Double, j As Double, k As Double
        n = Rango.Rows.Count: m = Rango.Columns.Count: k = n * m
        ReDim x(n, m)
        For i = 1 To n Step 1
            For j = 1 To m Step 1
                x(i, j) = Application.Large(Rango, k)
                k = k - 1
            Next j
        Next i
        SORT = x
    Else
        Exit Function
    End If
End Function

Question 11

Đây là những gì tôi sử dụng để sắp xếp trong bộ nhớ - nó có thể dễ dàng được mở rộng để sắp xếp một mảng.

Sub sortlist()

    Dim xarr As Variant
    Dim yarr As Variant
    Dim zarr As Variant

    xarr = Sheets("sheet").Range("sing col range")
    ReDim yarr(1 To UBound(xarr), 1 To 1)
    ReDim zarr(1 To UBound(xarr), 1 To 1)

    For n = 1 To UBound(xarr)
        zarr(n, 1) = 1
    Next n

    For n = 1 To UBound(xarr) - 1
        y = zarr(n, 1)
        For a = n + 1 To UBound(xarr)
            If xarr(n, 1) > xarr(a, 1) Then
                y = y + 1
            Else
                zarr(a, 1) = zarr(a, 1) + 1
            End If
        Next a
        yarr(y, 1) = xarr(n, 1)
    Next n

    y = zarr(UBound(xarr), 1)
    yarr(y, 1) = xarr(UBound(xarr), 1)

    yrng = "A1:A" & UBound(yarr)
    Sheets("sheet").Range(yrng) = yarr

End Sub

Question 12

Thực hiện Heapsort . Một thuật toán sắp xếp không ổn định ở vị trí O (n log (n)) (cả trường hợp trung bình và trường hợp xấu nhất) .

Sử dụng với: Call HeapSort(A), nơi Alà một trong những mảng chiều của biến thể, với Option Base 1.

Sub SiftUp(A() As Variant, I As Long)
    Dim K As Long, P As Long, S As Variant
    K = I
    While K > 1
        P = K \ 2
        If A(K) > A(P) Then
            S = A(P): A(P) = A(K): A(K) = S
            K = P
        Else
            Exit Sub
        End If
    Wend
End Sub

Sub SiftDown(A() As Variant, I As Long)
    Dim K As Long, L As Long, S As Variant
    K = 1
    Do
        L = K + K
        If L > I Then Exit Sub
        If L + 1 <= I Then
            If A(L + 1) > A(L) Then L = L + 1
        End If
        If A(K) < A(L) Then
            S = A(K): A(K) = A(L): A(L) = S
            K = L
        Else
            Exit Sub
        End If
    Loop
End Sub

Sub HeapSort(A() As Variant)
    Dim N As Long, I As Long, S As Variant
    N = UBound(A)
    For I = 2 To N
        Call SiftUp(A, I)
    Next I
    For I = N To 2 Step -1
        S = A(I): A(I) = A(1): A(1) = S
        Call SiftDown(A, I - 1)
    Next
End Sub

Question 13

@Prasand Kumar, đây là một quy trình sắp xếp hoàn chỉnh dựa trên các khái niệm của Prasand:

Public Sub ArrayListSort(ByRef SortArray As Variant)
    '
    'Uses the sort capabilities of a System.Collections.ArrayList object to sort an array of values of any simple
    'data-type.
    '
    'AUTHOR: Peter Straton
    '
    'CREDIT: Derived from Prasand Kumar's post at: /programming/152319/vba-array-sort-function
    '
    '*************************************************************************************************************

    Static ArrayListObj As Object
    Dim i As Long
    Dim LBnd As Long
    Dim UBnd As Long

    LBnd = LBound(SortArray)
    UBnd = UBound(SortArray)

    'If necessary, create the ArrayList object, to be used to sort the specified array's values

    If ArrayListObj Is Nothing Then
        Set ArrayListObj = CreateObject("System.Collections.ArrayList")
    Else
        ArrayListObj.Clear  'Already allocated so just clear any old contents
    End If

    'Add the ArrayList elements from the array of values to be sorted. (There appears to be no way to do this
    'using a single assignment statement.)

    For i = LBnd To UBnd
        ArrayListObj.Add SortArray(i)
    Next i

    ArrayListObj.Sort   'Do the sort

    'Transfer the sorted ArrayList values back to the original array, which can be done with a single assignment
    'statement.  But the result is always zero-based so then, if necessary, adjust the resulting array to match
    'its original index base.

    SortArray = ArrayListObj.ToArray
    If LBnd <> 0 Then ReDim Preserve SortArray(LBnd To UBnd)
End Sub

Question 14

Hơi liên quan, nhưng tôi cũng đang tìm giải pháp VBA excel gốc vì cấu trúc dữ liệu nâng cao (Từ điển, v.v.) không hoạt động trong môi trường của tôi. Sau đây thực hiện sắp xếp thông qua cây nhị phân trong VBA:

Giả sử mảng được điền từng cái một
Loại bỏ các bản sao
Trả về một chuỗi được phân tách ( "0|2|3|4|9") sau đó có thể được tách.

Tôi đã sử dụng nó để trả về một danh sách được sắp xếp thô của các hàng được chọn cho một phạm vi được chọn tùy ý

Private Enum LeafType: tEMPTY: tTree: tValue: End Enum
Private Left As Variant, Right As Variant, Center As Variant
Private LeftType As LeafType, RightType As LeafType, CenterType As LeafType
Public Sub Add(x As Variant)
    If CenterType = tEMPTY Then
        Center = x
        CenterType = tValue
    ElseIf x > Center Then
        If RightType = tEMPTY Then
            Right = x
            RightType = tValue
        ElseIf RightType = tTree Then
            Right.Add x
        ElseIf x <> Right Then
            curLeaf = Right
            Set Right = New TreeList
            Right.Add curLeaf
            Right.Add x
            RightType = tTree
        End If
    ElseIf x < Center Then
        If LeftType = tEMPTY Then
            Left = x
            LeftType = tValue
        ElseIf LeftType = tTree Then
            Left.Add x
        ElseIf x <> Left Then
            curLeaf = Left
            Set Left = New TreeList
            Left.Add curLeaf
            Left.Add x
            LeftType = tTree
        End If
    End If
End Sub
Public Function GetList$()
    Const sep$ = "|"
    If LeftType = tValue Then
        LeftList$ = Left & sep
    ElseIf LeftType = tTree Then
        LeftList = Left.GetList & sep
    End If
    If RightType = tValue Then
        RightList$ = sep & Right
    ElseIf RightType = tTree Then
        RightList = sep & Right.GetList
    End If
    GetList = LeftList & Center & RightList
End Function

'Sample code
Dim Tree As new TreeList
Tree.Add("0")
Tree.Add("2")
Tree.Add("2")
Tree.Add("-1")
Debug.Print Tree.GetList() 'prints "-1|0|2"
sortedList = Split(Tree.GetList(),"|")