Excel 数组和小型 VBA 循环与不带数组的大型 VBA 循环的性能

Question

我有两个工作表。第一个（计算）包含 10.000 行，其中包含许多 RTD 公式和不同的计算。第二个（观察者）观察第一个。
我有一个每秒运行的 VBA 脚本并检查工作表 1（计算）的每一行。如果循环在工作表 1 上找到一些标记的数据，则它将一些数据从 WS1 复制到 WS2。

解决方案 1：循环检查 10.000 行

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For I = 1 To 10000
    If CStr(.Cells(I, 1)) = "X" Then
        'DO SOME SUFF (copy the line from WS 1 to WS2)
        'Find first empty row
        LR2 = WS2.Cells(15, 1).End(xlDown).Row + 1
        'Copy data from WS1 to WS2
        WS1.Range(.Cells(I, 1), .Cells(I, 14)).Copy
        WS2.Cells(LR2, 1).PasteSpecial xlValues
    End If
Next

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

解决方案 2：带有小循环的数组函数
我可以使用 Excel 数组而不是 10.000 行循环来观察 10.000 行并用较小的数组做一些事情吗？

在工作表 2 上，我会有以下代码：(A1:O15)

{=index(Calculation!A$1:$O$10000; .....)....))}

我将再次通过 15 行数组函数进行更小的循环：

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For K = 1 To 15
    If CStr(.Cells(I, 1)) = "X" Then
        'Find first empty row
        LR2 = WS2.Cells(15, 1).End(xlDown).Row + 1
        'Copy data from WS1 to WS2
        WS1.Range(.Cells(I, 1), .Cells(I, 14)).Copy
        WS2.Cells(LR2, 1).PasteSpecial xlValues
    End If
Next

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

我想知道哪种方案的性能更好。

我不确定超过 10.000 行的 Excel 数组是否具有良好的性能。 15-rowLoop 肯定比 10000-row-Loop 快。

我不知道如何衡量与数组相关的 15 行循环（观察 10.000 行）是否更快。

Answer 1

使用条件复制到工作表

• 将工作表中包含指定列中的指定值 (Criteria) 的数据集的每一行复制到另一个工作表。
• 调整createReport常量部分的值。
• 数据传输只会（总是）在工作表“Observer”被激活时发生，例如当前选择了另一个工作表并单击“Observer”选项卡时。​​li>
• 在我的机器上，此代码在一百万（全部）行中花费了大约 5 秒，而对于 100.000 行则不到一秒。
• 通过在“Calculation”工作表中使用带有Worksheet Change 事件的代码并关闭某些Application 事件（例如.ScreenUpdating、.Calculation、.EnableEvents），可以进一步提高效率.

Excel 测试设置（工作表“计算”）

[A1:I1] ="Column "&COLUMN()
[A2]    =IF(I2=1,"X","Y")
[B2:H2] =RANDBETWEEN(1,1000)
[I2]    =RANDBETWEEN(1,100)

工作表模块（工作表“观察者”）

Option Explicit

Private Sub Worksheet_Activate()
    createReport
End Sub

标准模块，例如Module1

Option Explicit

Sub createReport()
    
    ' Constants
    
    ' Source
    Const srcName As String = "Calculation"
    Const CriteriaColumn As Long = 1
    Const Criteria As String = "X"
    Const srcFirstCellAddress As String = "A1"
    ' Target
    Const tgtName As String = "Observer"
    Const tgtFirstCellAddress As String = "A1"
    Const includeHeaders As Boolean = True
    ' Other
    Dim wb As Workbook
    Set wb = ThisWorkbook ' The workbook containing this code.
    
    ' Define Source Range ('rng').
    
    ' Define Source First Cell ('cel').
    Dim cel As Range
    Set cel = wb.Worksheets(srcName).Range(srcFirstCellAddress)
    ' Define the Current Region ('rng') 'around' First Cell.
    Dim rng As Range
    Set rng = cel.CurrentRegion
    ' Define Source Range ('rng') i.e. exclude cells to the left and above
    ' of Source First Cell from the Current Region.
    Set rng = rng.Resize(rng.Rows.Count - cel.Row + rng.Row, _
                         rng.Columns.Count - cel.Column + rng.Column) _
                 .Offset(cel.Row - rng.Row, cel.Column - rng.Column)

    
    ' Write values from Source Range to Data Array ('Data').
    
    Dim Data As Variant
    Data = rng.Value
    
    ' Write resulting values from Data Array to Data Array
    ' i.e. 'shift' them to the beginning.
    
    Dim NoC As Long             ' Number of Columns
    NoC = UBound(Data, 2)
    Dim i As Long               ' Source Data Rows Counter
    Dim j As Long               ' Source/Target Data Columns Counter
    Dim CurrentRow As Long      ' Target Data Rows Counter
    Dim checkHeaders As Long
    checkHeaders = -CLng(includeHeaders) ' True is '-1' in VBA.
    CurrentRow = checkHeaders
    
    For i = 1 To UBound(Data, 1)
        If Data(i, CriteriaColumn) = Criteria Then
            CurrentRow = CurrentRow + 1
            For j = 1 To NoC
                ' 'Shift' from 'i' to 'CurrentRow'.
                Data(CurrentRow, j) = Data(i, j)
            Next j
        End If
    Next i
    
    ' Write values from Data Array to Target Range ('rng').
    
    ' Define Target First Cell ('cel').
    Set cel = wb.Worksheets(tgtName).Range(tgtFirstCellAddress)
    ' Define Target First Row ('rng').
    Set rng = cel.Resize(, NoC)
    ' Clear contents in columns.
    rng.Resize(rng.Worksheet.Rows.Count - cel.Row + 1).ClearContents
    
    Select Case CurrentRow
        Case 0
            GoTo CriteriaNotFound
        Case checkHeaders
            ' Write headers from Data Array to Target Range.
            rng.Resize(CurrentRow).Value = Data
            GoTo CriteriaNotFound
        Case Else
            ' Write values from Data Array to Target Range.
            rng.Resize(CurrentRow).Value = Data
            GoTo Success
    End Select

    ' Exit.

ProcExit:
    Exit Sub
    
    ' Inform user.

CriteriaNotFound:
    MsgBox "Value '" & Criteria & "' not found.", vbExclamation, "Fail"
    GoTo ProcExit
Success:
    MsgBox CurrentRow - checkHeaders & " row(s) of data transferred.", _
           vbInformation, "Success"
    GoTo ProcExit
    
End Sub

Answer 2

与其返回列 A 10,000 次，不如将所有值放入一维 VBA 数组中，然后遍历该数组：

Sub whatever()
    Dim rng As Range, arr
    
    Set rng = Sheets("Calculation").Range("A1:A10000")
    arr = WorksheetFunction.Transpose(rng)
    
    For i = 1 To 10000
        If arr(i) = "X" Then
            'do some stuff
        End If
    Next i
End Sub

如果 X 很少，那么它可能几乎是瞬时的。

编辑#1：

根据 Chris Neilsen 的评论，这里有一个不使用Transpose()的版本：

Sub whatever2()
    Dim rng As Range, arr

    Set rng = Sheets("Calculation").Range("A1:A10000")
    arr = rng

    For i = 1 To 10000
        If arr(i, 1) = "X" Then
            'do some stuff
        End If
    Next i
End Sub

Answer 3

请测试下一个代码。它应该非常快，使用数组和内存中发生的一切。该代码假定您需要复制从 WS2 的最后一个空单元格开始的所有匹配项：

Sub CopyFromWS1ToWs2Array()
  Dim WS1 As Worksheet, WS2 As Worksheet, lastRow As Long, searchStr As String
  Dim LR2 As Long, arr1 As Variant, arr2 As Variant, i As Long, k As Long, j As Long
  
  Set WS1 = ActiveSheet 'use here your necessary sheet
  Set WS2 = WS1.Next    'use here your necessary sheet. I used this only for testing reason
  lastRow = WS1.Range("A" & rows.count).End(xlUp).row 'last row of the first sheet
  
  arr1 = WS1.Range("A1:N" & lastRow).Value           'put the range in an array
  ReDim arr2(1 To UBound(arr1, 2), 1 To UBound(arr1)) 'redim the array to be returned
                                                      'columns and rows are reversed because
                                                      'only the second dimension can be Redim Preserve(d)
  
  searchStr = "X"      'setting the search string
  For i = 1 To UBound(arr1)
   If arr1(i, 1) = searchStr Then
        k = k + 1 'the array row is incremented (in fact, it is the column now...)
        For j = 1 To UBound(arr1, 2)
            arr2(j, k) = arr1(i, j) 'the row is loaded with all the necessary values
        Next j
   End If
 Next i
 'the final array is Redim, preserving only the existing values:
 ReDim Preserve arr2(1 To UBound(arr1, 2), 1 To k)
 LR2 = WS2.cells(rows.count, 1).End(xlUp).row + 1 'last empty row of the second worksheet
 'Dropping the array content at once (the fastest way of copying):
 WS2.Range("A" & LR2).Resize(UBound(arr2, 2), UBound(arr2)).Value = _
                                      WorksheetFunction.Transpose(arr2)
 WS2.Activate: WS2.Range("A" & LR2).Select
 MsgBox "Ready...", vbInformation, "Job done"
End Sub

已编辑：

请测试下一个代码，它也应该可以解决您的最后一个请求（据我了解）：

Sub CopyFromWS1ToWs2ArrayBis()
  Dim WS1 As Worksheet, WS2 As Worksheet, lastRow As Long, searchStr As String
  Dim LR2 As Long, arr1 As Variant, arr2 As Variant, arrWS2 As Variant
  Dim i As Long, k As Long, j As Long, s As Long, boolFound As Boolean
  
  Set WS1 = ActiveSheet 'use here your necessary sheet
  Set WS2 = WS1.Next    'use here your necessary sheet. I used this only for testing reason
  lastRow = WS1.Range("A" & rows.count).End(xlUp).row 'last row of the first sheet
  LR2 = WS2.cells(rows.count, 1).End(xlUp).row   'last empty row of the second worksheet
  
  arr1 = WS1.Range("A1:N" & lastRow).Value            'put the range of WS1 in an array
  ReDim arr2(1 To UBound(arr1, 2), 1 To UBound(arr1)) 'redim the array to be returned
                                                      'columns and rows are reversed because
                                                      'only the second dimension can be Redim Preserve(d)
  arrWS2 = WS2.Range("A1:N" & LR2).Value   'put the range of WS2 in an array
  searchStr = "X"                          'setting the search string
  For i = 1 To UBound(arr1)
   If arr1(i, 1) = searchStr Then
        For s = 1 To UBound(arrWS2)
            If arr1(i, 1) = arrWS2(s, 1) And arr1(i, 2) = arrWS2(s, 2) And _
                                              arr1(i, 3) = arrWS2(s, 3) Then
                boolFound = True: Exit For  'if first three array columns are the same
            End If
        Next s
        If Not boolFound Then               'if first thrree array columns not the same:
            k = k + 1                       'the array row is incremented
            For j = 1 To UBound(arr1, 2)
                arr2(j, k) = arr1(i, j) 'the row is loaded with all the necessary values
            Next j
            'swap the columns 4 and 5 values:
            If arr1(i, 4) = "ABC" And arr1(i, 5) = "XYZ" Then arr2(4, k) = "XYZ": arr2(5, k) = "ABC"
        End If
        boolFound = False              'reinitialize the boolean variable
   End If
 Next i
 
 If k > 0 Then
    'Preserving only the existing array elements:
    ReDim Preserve arr2(1 To UBound(arr1, 2), 1 To k)
    
    'Dropping the array content at once (the fastest way of copying):
    WS2.Range("A" & LR2 + 1).Resize(UBound(arr2, 2), UBound(arr2)).Value = _
                                         WorksheetFunction.Transpose(arr2)
    WS2.Activate: WS2.Range("A" & LR2 + 1).Select
    MsgBox "Ready...", vbInformation, "Job done"
 Else
    MsgBox "No any row to be copied!", vbInformation, "Nothing changed"
 End If
End Sub