Question

上下文：我试图了解有关数组及其使用的更多信息，特别是因为我了解到循环可能具有巨大的运行时，从而将其使用限制为仅几次迭代。实际上，与此问题相关，我制作了一个简单的VBA宏，该宏在8000个单元格上运行IFstatements，只要结果为正，它就会将整行移动到另一张纸上。不用说，秒表监视此宏花了我大约10分钟的时间，使我得出结论，肯定有一种更快的方法，否则使用Macro的整个观点将被淘汰。我什至尝试使用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的条目，并将这些值复制到最后一列

数据样本

   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的数量

    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

VBA阵列中的IF语句比循环更快地运行代码

1 个答案: