Сортировка в указанном диапазоне и l oop до завершения - VBA Excel Marcro

Question

Это снова я. Я пробовал разные варианты сортировки строк на основе Col D для каждой коллекции.

Это самая близкая, но найдены 2 ошибки.

1- L oop и не в состоянии выйти, когда он достигает последних использованных строк. Сортировка продолжается до тех пор, пока я не нажму, чтобы принудительно завершить. 2 - Невозможно выполнить сортировку, если в коллекции имеется только один SKU. Также сортируется следующая коллекция. Иногда 3 коллекции отсортированы. например, перед запуском - строки 9, 29, 32, 35, 45 ....

Вот мой код. Что не так с моим кодом?

Sub SortingCollectionOnColD
With ActiveSheet.Range("A:A")
    Set FindSubtotal = .Find("Subtotal", After:=.Range("A1"), LookIn:=xlValues)
        If Not FindSubtotal Is Nothing Then
            firstOne = FindSubtotal.Address
            Do
                With FindSubtotal
                        Range("A" & FindSubtotal.Row - 1).Select
                        Set SortRange = Range(Selection, Selection.End(xlUp)).EntireRow
                        ActiveSheet.Sort.SortFields.Clear
                            ActiveSheet.Sort.SortFields.Add Key:=Range("C" & FindSubtotal.Row) _
                                , SortOn:=xlSortOnValues, Order:=xlAscending
                            With ActiveSheet.Sort
                                .SetRange SortRange
                                .Header = xlNo
                                .Orientation = xlTopToBottom
                                .Apply
                            End With
                End With
                Set FindSubtotal = .FindNext(FindSubtotal)
            Loop While Not FindSubtotal Is Nothing And FindSubtotal.Address <> firstOne
        End If
End With End Sub

Перед запуском

Ожидаемый результат

После пробега. выделены основные сбои

Answer 1

Пожалуйста, проверьте следующий код, пожалуйста. Я не мог воспроизвести ваш лист, и я изменил ссылку на лист вместо A: диапазон, где он выглядит мне логично c, но не зная, что вы хотите сделать, было бы невозможно не вернуть то, что именно вам нужно. Пожалуйста, дайте мне знать, если / как это соответствует вашим потребностям.

Sub LoopSubtotal()
  Dim FindSubtotal As Range, sh As Worksheet, firstOne As String
  Dim SortRange As Range
   Set sh = ActiveSheet
   With sh.Range("A:A")
    Set FindSubtotal = .Find("Subtotal", After:=.Range("A1"), LookIn:=xlValues)
    If Not FindSubtotal Is Nothing Then
            firstOne = FindSubtotal.Address
            Do
                sh.Range("A" & FindSubtotal.row - 1).Select
                Set SortRange = Range(Selection, Selection.End(xlUp)).EntireRow
                sh.Sort.SortFields.Clear
                    sh.Sort.SortFields.Add Key:=sh.Range("C" & FindSubtotal.row) _
                        , SortOn:=xlSortOnValues, Order:=xlAscending
                    With sh.Sort
                        .SetRange SortRange
                        .Header = xlNo
                        .Orientation = xlTopToBottom
                        .Apply
                    End With
                    Set FindSubtotal = .FindNext(FindSubtotal): Debug.Print FindSubtotal.Address
            Loop While Not FindSubtotal Is Nothing And FindSubtotal.Address <> firstOne
        End If
   End With
End Sub

Попробуйте, пожалуйста, запустите его построчно, нажав F8 и посмотрите, что он делает.