Добавление рекурсивного цикла / функции в сортировку в VBA - PullRequest
0 голосов
/ 03 октября 2019

Итак, у меня есть пузырьковая сортировка, но на данный момент она работает только с первым элементом. Это решается путем переоценки элементов массива и их размещения соответствующим образом, что происходит, если я запускаю все это, нажимая кнопку снова и снова. Вместо этого я хотел бы добавить рекурсивный цикл, который должен прерываться после завершения сортировки. Я попытался добавить функцию, но у меня недостаточно четкого синтаксиса, чтобы объединить ее с моим сабом. Может ли кто-нибудь предоставить мне базовый цикл рекурсии для этого кода? Функция явно не требуется, просто то, что позволит мне вспомнить мой саб.

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

1 Ответ

0 голосов
/ 03 октября 2019

Узнал, что мне нужно было сделать. Поместите все это в цикл 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
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...