IFstatements в массивах VBA для выполнения кода быстрее, чем циклы

Question

Контекст : я пытаюсь узнать больше о массивах и их использовании, особенно потому, что я узнал, что циклы могут иметь огромное время выполнения, ограничивая их использование всего несколькими итерациями.Фактически, в связи с этой проблемой, я создал простой макрос VBA, который запускает IF-отчеты на 8000 ячеек, и всякий раз, когда результат будет положительным, он будет перемещать всю строку на другой лист.Само собой разумеется, что остановка этого макроса заняла у меня около 10 минут, и я пришел к выводу, что должен быть более быстрый путь, иначе весь смысл использования макроса просто устареет.Я даже пытался использовать Application.Calculation / EnableEvents / ScreenUpdating, чтобы найти более быстрое решение, но мне потребовалось еще 10 минут, чтобы запустить все это.

Пример кода цикла :

Public Sub MoveOutTyres()
'this macro moves Pneu Complete, Hiver or Ete and Status 1 tyres in their sheets: it should be under Test worksheet
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.ScreenUpdating = False



'Declare All Variables
Dim myCell As Range
Dim LastRow As Integer
Dim myRange As Range
Dim LastCol As Integer
Dim ws As Worksheet



'frame the table
    With ThisWorkbook

    LastRow = Range(Cells(1, 1), Cells(1, 1).End(xlDown)).Count
    LastCol = Range(Cells(1, 1), Cells(1, 1).End(xlToRight)).Count



            'the following code will verify if the worksheet Pneu_Complete exists or not

                   Dim wsSheet2 As Worksheet
                   On Error Resume Next
                   Set wsSheet2 = Sheets("Pneu_Complete")
                   On Error GoTo 0
                   If Not wsSheet2 Is Nothing Then
                        MsgBox "The worksheet Pneu_Complete exists"
                        Else
                        MsgBox "The worksheet Pneu_Complete does not exist please create a worksheet with the name: 'Pneu_Complete'"
                   End If


'Create a ListObjects table of a specific size

On Error Resume Next
    Worksheets("Test").ListObjects.Add(xlSrcRange, Range(Cells(1, 1), Cells(LastRow, LastCol)), , xlYes).Name = _
      "data_gardi_LPLU"
    ActiveSheet.ListObjects("data_gardi_LPLU").TableStyle = "TableStyleLight2"
On Error GoTo 0


'move rows with specific criteria
                    'move rows with Pneu tyre in worksheet Pneu_Complete

                    For m = 2 To LastRow

                        With ThisWorkbook.Sheets("Test").ListObjects("data_gardi_LPLU")

                        Set myRange = ThisWorkbook.Sheets("Test").ListObjects("data_gardi_LPLU").ListColumns("Season").DataBodyRange
                            For Each myCell In myRange
                                If myCell.Value = "Summer" Then
                                        myCell.EntireRow.Cut                                             
                                        m = m + 1

                                End If
                            Next
                        End With 
                    Next
For i = 1 To CntRow_updated
    Set myRange = Range(Cells(2, 2), Cells(LastRow, 2))

        For Each myCell In myRange
        myCell.Offset(0, LastCol - 3).Value = WorksheetFunction.CountIf(myRange, myCell.Value)
        Next


Next         
    End With

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = False

End Sub

Требуемый код : я бы хотел, чтобы мой код считывал значения из таблицы Excel, затем сохранял строку ввода в массиве и копировал строки, которые соответствуют определенным критериям, на другой лист.В итоге я хотел бы подсчитать, сколько записей с одинаковым идентификатором у меня в наборе данных, и скопировать такие значения в последний столбец

Образец данных

   ID     Tyre_Width    Tyre_Diameter  Season
   101    15            50cm           Winter
   101    15            50cm           Winter
   101    15            50cm           Winter
   101    15            50cm           Winter
   201    14            55cm           Summer
   201    14            55cm           Summer
   102    18            50cm           Winter
   102    18            50cm           Winter

Результат данных : Как объяснено до того, как оператор IF будет использоваться для удаления в этом примере летних шин, а затем мне нужно будет подсчитать количество идентификаторов в последнем столбце

    ID     Tyre_Width    Tyre_Diameter  Season   Cnt
    101    15            50cm           Winter   4    
    101    15            50cm           Winter   4    
    101    15            50cm           Winter   4    
    101    15            50cm           Winter   4    
    102    18            50cm           Winter   2    
    102    18            50cm           Winter   2

Answer 1

После просмотра руководства на Youtube о том, как создавать и изменять массивы, я наконец-то смог найти решение. Видеогид, который я смотрел, можно найти здесь https://www.youtube.com/watch?v=h9FTX7TgkpM. Если быть точным, я воспроизвел макрос, показанный в последнем упражнении. После вы можете найти код.

Sub Array_Winter()
    Dim Arr() As Variant
    Dim r As Range
    Dim Counter As Long, LoopCounter As Long

    Sheet1.Activate

    For Each r In Range("A2", Range("A1").End(xlDown))

        If LCase(r.Offset(0, 7).value) = "Winter" Then
            Counter = Counter + 1

            ReDim Preserve Arr(1 To 21, 1 To Counter)

            For LoopCounter = 1 To 21
                Arr(LoopCounter, Counter) = r.Offset(0, LoopCounter - 1)
            Next LoopCounter

        End If

    Next r

    Worksheets("Winter").Activate
    Worksheets("Winter").Range("A1", Range("A1").Offset(UBound(Arr, 2) - 1, 20)).value = Application.Transpose(Arr)

End Sub