將遞歸循環/函數添加到 VBA 中的排序中

Question

我有一個僅適用於第一個元素的冒泡排序。

這可以通過重新評估我的數組元素並相應地放置它們來解決，如果我一次又一次地運行整個事情就會發生這種情況。

我想添加一個遞歸循環，當排序完成時設置為中斷。

我嘗試添加一個 function，但我的語法不夠扎實，無法將它與我的 sub 結合起來。 這段代碼的基本遞歸循環是什么？ Function 沒有明確要求，只是讓我想起我的潛艇。

Private Sub SortEverything_Click()

    Dim everything() As Range
    Dim check As Range
    Dim count As Range
    Dim sorting As Range
    Dim holder As Range
    Dim middleman As Range
    Dim firstman As Range

    Dim Temp1 As String
    Dim Temp2 As String

    Dim lr As Long
    Dim x As Long
    Dim y As Long
    Dim z As Long
    Dim q As Long
    Dim everyrow As Long
    Dim everycol As Long
    Dim firstrow As Long
    Dim firstcol As Long

    y = 0
    z = 0
    q = 0
    With ThisWorkbook.Sheets("Names and Vendors")
        lr = .Cells(.Rows.count, "B").End(xlUp).Row

        'Counts number of RMs to size the "everything" array
        For z = 2 To lr
            Set count = .Range("B" & z)
            If IsEmpty(count) = False Then
                count.Select
                q = q + 1
            End If
        Next z
        ReDim everything(q - 1) As Range 'Resizes array

        'Loops all RM info into array by each distinct range
        For x = 2 To lr
            Set check = .Range("A" & x & ":H" & x)
            'ensures subcomponents are added to range
            If IsEmpty(.Range("B" & 1 + x)) = True Then
                Do While IsEmpty(.Range("B" & 1 + x)) = True And x < lr
                    Set check = Union(check, .Range("A" & 1 + x & ":H" & 1 + x))
                    check.Select
                    x = x + 1
                Loop
            End If

            Set everything(y) = check
            y = y + 1
            check.Select
        Next x

        'This For has been commented out so that it doesn't run more than once 
        'For y = 0 To q - 1

        'sorting allows us to copy/paste into a helper range line-by-line as the program loops
        'firstman is the helper range. firstrow and firstcol return the dimensions of the everything(y) so that we can resize things
        Set sorting = everything(0)
        Set firstman = .Range("B20")
        Set firstman = firstman.Resize(sorting.Rows.count, sorting.Columns.count)
        firstman.Value = sorting.Value
        firstrow = firstman.Rows.count
        firstcol = firstman.Columns.count

        'Returns the name of the RM listed to compare to the one below it
        sorting.Offset(0, 1).Select
        ActiveCell.Select
        Temp1 = "" & ActiveCell.Value

        For x = 1 To q - 1

            'Checks whether a selected component has subcomponents and identifies its dimensions
            sorting.Select
            Set holder = everything(x)
            holder.Offset(0, 1).Select
            everyrow = Selection.Rows.count
            everycol = Selection.Columns.count

            'Returns the name of the material being compared to the referenced material in everything(y)
            ActiveCell.Select
            Temp2 = "" & ActiveCell.Value

            If Temp2 > Temp1 Then 'If the RM we're on comes alphabetically after the name of the one we're checking against, then

                If everyrow > 1 Then 'Handles if everything(x) has subcomponents

                    'Resize the other helper range to be the same as the range with subcomponents and paste the values into it
                    Set middleman = .Range("A1").Offset(0, everything(x).Columns.count)
                    Set middleman = middleman.Resize(everyrow, everycol)
                    middleman.Select
                    middleman.Value = holder.Value

                    'Resize the range we're pasting into in the master table so it can take the new range, then paste
                    Set sorting = sorting.Resize(everyrow, everycol)
                    sorting.Select
                    sorting.Value = holder.Value

                    'Resize the holder column to the same size as everything(y).
                    'Then paste everything(y) into the space BELOW the one we've just shifted upwards
                    Set holder = holder.Resize(firstrow, firstcol)
                    Set holder = holder.Offset(everyrow - 1, 0)
                    holder.Select
                    holder.Value = firstman.Value

                    Set sorting = sorting.Offset(everyrow, 0)

                Else

                    Set middleman = .Range("A1").Offset(0, everything(x).Columns.count)
                    Set middleman = middleman.Resize(firstrow, firstcol)
                    middleman.Select
                    middleman.Value = holder.Value
                    Set sorting = sorting.Resize(everyrow, everycol)
                    sorting.Select
                    sorting.Value = holder.Value
                    Set holder = holder.Resize(firstrow, firstcol)
                    'Set firstman = firstman.Resize(everyrow, everycol)

                    holder.Select
                    holder = firstman.Value

                    Set sorting = sorting.Offset(1, 0)
                End If
            End If
        Next x
        'Next y
        'This is where my inexperience shows. The recursion should go here, but I'm not sure how to do so.
        'PopulateArray (everything)
    End With
End Sub


Public Function PopulateArray(myArray()) As Variant
    Dim myArray() As Range
    Dim check As Range
    Dim count As Range
    Dim sorting As Range
    Dim holder As Range
    Dim middleman As Range
    Dim firstman As Range

    Dim Temp1 As String
    Dim Temp2 As String

    Dim lr As Long
    Dim x As Long
    Dim y As Long
    Dim z As Long
    Dim q As Long

    y = 0
    z = 0
    q = 0
    With ThisWorkbook.Sheets("Names and Vendors")
        lr = .Cells(.Rows.count, "B").End(xlUp).Row

        'Counts number of RMs to size the "myArray" array
        For z = 2 To lr
        Set count = .Range("B" & z)
            If IsEmpty(count) = False Then
                count.Select
                q = q + 1
            End If
        Next z
        ReDim myArray(q - 1) As Range 'Resizes array

        'Loops all RM info into array by each distinct range
        For x = 2 To lr
            Set check = .Range("A" & x & ":H" & x)
            'ensures subcomponents are added to range
            If IsEmpty(.Range("B" & 1 + x)) = True Then
                Do While IsEmpty(.Range("B" & 1 + x)) = True And x < lr
                    Set check = Union(check, .Range("A" & 1 + x & ":H" & 1 + x))
                    check.Select
                    x = x + 1
                Loop
            End If

            Set myArray(y) = check
            y = y + 1
            check.Select
        Next x
    End With
End Function

Answer 1

找出我需要做的事情。 將整個內容放在Do循環下，然后添加以下行：

    'checking to see if array is completely alphabetized
    For Each cell In .Range("B2:B" & lr)

        'Returns first check value
        If IsEmpty(cell) = False Then
            cell.Select
            check1 = "" & cell.Value
            x = cell.Row
            .Range("A14").Value = check1
                'Returns next check value
                For z = x + 1 To lr
                    Set checking = .Range("B" & z)
                    If IsEmpty(checking) = False Then
                        checking.Select
                        check2 = "" & .Range("B" & z).Value
                        .Range("A15").Value = check2
                        Exit For
                    End If

                Next z

        Else
        End If

        If check2 > check1 Then
        Exit For
        End If
        Next cell

 'If the last two values are sorted, then the whole thing is sorted and we can stop the recursion
 If check2 < check1 Or check1 = check2 Then
    Exit Do
 End If