Performance of Excel Array and small VBA Loop vs. Big VBA Loop w/o Array

Question

I've got two worksheets. The first (Calculation) contains 10.000 rows with a lot of RTD formulas and different calculations. The second (observer) observes the first one.
I've got a VBA script that runs every second and checks every row of worksheet 1 (Calculation). If the loop finds some marked data on worksheet 1 then it will copy some data from WS1 to WS2.

Solution 1: Loop checking 10.000 rows

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

Solution 2: Array function with a small loop
Can I use, instead of the 10.000 row loop, an Excel Array to observe the 10.000 rows and do some stuff with the smaller array.

On worksheet 2, I would have this code: (A1:O15)

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

Again I would have a smaller loop through the 15 lines of array function:

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

I would like to know what solution has the better performance.

I am not sure if an Excel array over 10.000 rows has a good performance. For sure the 15-rowLoop is faster than a 10000-row-Loop.

I don't know how to measure if a 15-row Loop in connection with an array (observing 10.000 rows) is faster.

Answer 1

Rather than going back to column A 10,000 times, bring all the values into a 1D VBA array and then loop over that array:

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

If there are very few X's then it may be nearly instantaneous.

EDIT#1:

Based on Chris Neilsen's comment, here is a version that does not use 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 2

Copy to Sheet With Criteria

• Copies each row of a dataset in a worksheet containing a specified value (Criteria) in a specified column, to another worksheet.
• Adjust the values in the constants section of createReport.
• The data transfer will only (always) happen when the worksheet "Observer" is activated e.g. when another sheet is currently selected and the "Observer" tab is clicked on.
• This code took about 5 seconds for a million (all) rows, and under a second for 100.000 rows on my machine.
• The efficiency can further be improved by using the code with the Worksheet Change event in the "Calculation" worksheet and by turning off certain Application events (e.g. .ScreenUpdating, .Calculation, .EnableEvents).

Excel Test Setup (Worksheet "Calculation")

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

Sheet Module (Worksheet "Observer")

Option Explicit

Private Sub Worksheet_Activate()
    createReport
End Sub

Standard Module e.g. 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 3

Test the next code, please. It should be very fast, using arrays and everything happening in memory. The code assumes that you need to copy all occurrences starting with the last empty cell of 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

Edited:

Please, test the next code, which should also solve your last requests (as I understood them):

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