Speed up For Loop by using an Array

user_19416137 0
Viewed 107

I'm looking to speed up a For Loop (as per code below) by incorporating the use of an Array. Would really appreciate some advice on how to do this:

Sub DetectedCheck()
'counts rows in sheet 1 and 2.
With Sheets(1)
reconrows = .Range("a" & .Rows.Count).End(xlUp).Row
End With
 
 'Checks that the new data has both an assigned and detected role and adds "No Issue" to column Q if valid.
For i = 2 To reconrows
        If ActiveWorkbook.Sheets(1).Range("J" & i).Value <> "Not Found" And ActiveWorkbook.Sheets(1).Range("K" & i).Value <> "" Then
            ActiveWorkbook.Sheets(1).Range("S" & i).Value = "No Issue"
        End If
Next i
 
 
End Sub
for-loop vba excel arrays performance
3 Answers

Want to test this method and see the speed of looping with arrays compared to rows?

 Dim timmy, i As Long, rc As Long, arr1, arr2, arr3
 timmy = Timer
    With Sheets(1)
    rc = .Range("A" & Rows.Count).End(xlUp).Row
        arr1 = .Range("J2:J" & rc).Value
        arr2 = .Range("K2:K" & rc).Value
        ReDim arr3(1 To UBound(arr1), 1 To 1)
        For i = 1 To UBound(arr1, 1)
            If arr1(i, 1) = "Not Found" And IsEmpty(arr2(i, 1)) Then
                arr3(i, 1) = ""
            Else
                arr3(i, 1) = "No Issue"
            End If
        Next i
        .Range("S2:S" & rc).Value = arr3
    End With
    Debug.Print "Loopy", Timer - timmy
user_193845270

Please, try the next way:

Sub DetectedCheck()
 Dim sh As Worksheet, reconRows As Long, arrJK, arrS, i As Long

 Set sh = Sheets(1)
  reconRows = sh.Range("a" & sh.rows.count).End(xlUp).row
  arrJK = sh.Range("J2:K" & reconRows).value
  arrS = sh.Range("S2:S" & reconRows).value
  
 'Checks that the new data has both an assigned and detected role and adds "No Issue" to column Q if valid.
 For i = 1 To UBound(arrJK)
        If arrJK(i, 1) <> "Not Found" And arrJK(i, 2) <> "" Then
           arrS(i, 1) = "No Issue"
        End If
 Next i
 sh.Range("S2").Resize(UBound(arrS), 1).value = arrS
End Sub

But in the code comment you mention "No Issue" to column Q" and in your code you use S:S column. Please, adapt if the return must be done in Q:Q.

user_22333080

Loop Through Arrays Instead of Ranges

  • To speed up a loop, you can turn off the three most common 'speed-related' application settings: ScreenUpdating, Calculation, and EnableEvents. Often it doesn't help much.
  • The trick is to access the worksheet as few times as possible i.e. to write the values of the ranges to arrays (you could think of these 2D one-based arrays as ranges (in this case column ranges) in memory, starting in row 1, since they are handled similarly), loop over the arrays and write the results to another (resulting) array and write the values from the latter array to the resulting range.
  • The first code, the array code, took roughly 0.3 seconds for 100.000 rows of simple sample data (created with the PopulateRandomData procedure) resulting in about 25.000 No Issue cells.
  • For the same data, the second code, the range code, took roughly 2.5 seconds when the resulting (destination) column range was cleared previously. It took about 5 seconds if each cell was cleared in the loop (a mistake). It took 40 seconds if vbNullString or Empty were written in the loop (a huge mistake).
  • So the array code was roughly 8 times faster but depending on your data and how the code was previously written, the array code could be many more (tens or even hundreds of) times faster.
  • Note that the running times will be different for your data so your feedback is appreciated.
  • Check out these Excel Macro Mastery videos to quickly learn about arrays and their use to speed up code.
Option Explicit

Sub DetectedCheckArray()

    ' Constants
    Const wsID As Variant = 1 ' safer is to use the (tab) name, e.g. "Sheet1"
    Const fRow As Long = 2
    Const lrCol As String = "A" ' Last Row Column
    Const c1Col As String = "J" ' 1st Criteria Column
    Const c2Col As String = "K" ' 2nd Criteria Column
    Const NotCrit1 As String = "Not Found" ' 1st Criteria
    Const NotCrit2 As String = "" ' 2nd Criteria
    Const dCol As String = "S" ' Destination Column
    Const dString As String = "No Issue"
    ' If you use constants at the beginning of the code,
    ' you can easily change their values in one place without
    ' searching in the code.
    
    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the worksheet ('ws') (in the workbook).
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsID) '
    
    ' Calculate the last row ('lRow'),
    ' the row of the last non-empty cell in the column.
    Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, lrCol).End(xlUp).Row
    
    ' Calculate the number of rows ('rCount').
    Dim rCount As Long: rCount = lRow - fRow + 1
    ' Note that all ranges and arrays have this number of rows ('rCount').
    
    ' Validate the number of rows.
    If rCount < 1 Then
        MsgBox "No data in column range.", vbCritical
        Exit Sub
    End If
    
    ' Reference the last row (one-column) range ('lrrg') to be used
    ' to easily reference the remaining ranges.
    Dim lrrg As Range
    ' This may be more understandable (commonly used),...
    Set lrrg = ws.Range(ws.Cells(fRow, lrCol), ws.Cells(lRow, lrCol))
    ' ... but I prefer:
    'Set lrrg = ws.Cells(fRow, lrCol).Resize(rCount)
    
    ' Reference the criteria (one-column) ranges ('crg1' and 'crg2').
    Dim crg1 As Range: Set crg1 = lrrg.EntireRow.Columns(c1Col)
    Dim crg2 As Range: Set crg2 = lrrg.EntireRow.Columns(c2Col)
    ' If you have a reference to a one-column range ('lrrg') and you want
    ' to reference the same range in another worksheet column ('c1Col, c2Col'),
    ' use '.EntireRow' to easily do it, to not complicate with '.Offset'.
    
    ' The code so far runs in split seconds.
    ' The following is the improvement.
    
    ' Start measuring the time passed.
    Dim dt As Double: dt = Timer
    
    ' Write the values from the criteria ranges
    ' to 2D one-based one-column arrays ('cData1' and 'cData2').
    Dim cData1() As Variant
    Dim cData2() As Variant
    If rCount = 1 Then ' one cell
        ReDim cData1(1 To 1, 1 To 1): cData1(1, 1) = crg1.Value
        ReDim cData2(1 To 1, 1 To 1): cData1(1, 1) = crg2.Value
    Else ' multiple cells
        cData1 = crg1.Value
        cData2 = crg2.Value
    End If
    
    ' Define the destination string array ('dsData').
    Dim dsData() As String: ReDim dsData(1 To rCount, 1 To 1)
    
    Dim r As Long
    ' Loop through the rows ('r') of the arrays and for each row
    ' check the values of the criteria arrays against the (not) criterias.
    ' If all (both) conditions are met, write the destination string ('dString')
    ' to the current row of the destination string array.
    For r = 1 To rCount
        If StrComp(CStr(cData1(r, 1)), NotCrit1, vbTextCompare) <> 0 Then
            If StrComp(CStr(cData2(r, 1)), NotCrit2, vbTextCompare) <> 0 Then
                dsData(r, 1) = dString
            End If
        End If
    Next r
    
    ' Reference the destination (one-column) range ('drg').
    Dim drg As Range: Set drg = lrrg.EntireRow.Columns(dCol)
    
    ' Write the values from the destination string array
    ' to the destination range.
    drg.Value = dsData
 
    ' Inform.
    MsgBox "Finished in " & Timer - dt & " seconds.", vbInformation

End Sub

Sub DetectedCheckRange()

    ' Constants
    Const wsID As Variant = 1 ' safer is to use the (tab) name, e.g. "Sheet1"
    Const fRow As Long = 2
    Const lrCol As String = "A" ' Last Row Column
    Const c1Col As String = "J" ' 1st Criteria Column
    Const c2Col As String = "K" ' 2nd Criteria Column
    Const NotCrit1 As String = "Not Found" ' 1st Criteria
    Const NotCrit2 As String = "" ' 2nd Criteria
    Const dCol As String = "S" ' Destination Column
    Const dString As String = "No Issue"
    ' If you use constants at the beginning of the code,
    ' you can easily change their values in one place without
    ' searching in the code.
    
    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the worksheet ('ws') (in the workbook).
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsID) '
    
    ' Calculate the last row ('lRow'),
    ' the row of the last non-empty cell in the column.
    Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, lrCol).End(xlUp).Row
    
    ' Calculate the number of rows ('rCount').
    Dim rCount As Long: rCount = lRow - fRow + 1
    ' Note that all ranges and arrays have this number of rows ('rCount').
    
    ' Validate the number of rows.
    If rCount < 1 Then
        MsgBox "No data in column range.", vbCritical
        Exit Sub
    End If
    
    ' Reference the last row (one-column) range ('lrrg') to be used
    ' to easily reference the remaining ranges.
    Dim lrrg As Range
    ' This may be more understandable (commonly used),...
    Set lrrg = ws.Range(ws.Cells(fRow, lrCol), ws.Cells(lRow, lrCol))
    ' ... but I prefer:
    'Set lrrg = ws.Cells(fRow, lrCol).Resize(rCount)
    
    ' Reference the criteria (one-column) ranges ('crg1' and 'crg2').
    Dim crg1 As Range: Set crg1 = lrrg.EntireRow.Columns(c1Col)
    Dim crg2 As Range: Set crg2 = lrrg.EntireRow.Columns(c2Col)
    ' If you have a reference to a one-column range ('lrrg') and you want
    ' to reference the same range in another worksheet column ('c1Col, c2Col'),
    ' use '.EntireRow' to easily do it, to not complicate with '.Offset'.
    
    ' Reference the destination (one-column) range ('drg').
    Dim drg As Range: Set drg = lrrg.EntireRow.Columns(dCol)
    
    ' The code so far runs in split seconds.
    ' The following loop is what is slowing down the code.
    
    ' Start measuring the time passed.
    Dim dt As Double: dt = Timer
    
    ' Turn off application settings to speed up.
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    drg.ClearContents ' or drg.clear (2.5 seconds)
    
    Dim r As Long
    ' Loop through the rows ('r') of the column ranges and for each row
    ' check the values of the criteria ranges against the (not) criterias.
    ' If all (both) conditions are met, write the destination string ('dString')
    ' to the current row of the destination column.
    For r = 1 To rCount
        If StrComp(CStr(crg1.Cells(r).Value), NotCrit1, vbTextCompare) <> 0 Then
            If StrComp(CStr(crg2.Cells(r).Value), NotCrit2, vbTextCompare) _
                    <> 0 Then
                drg.Cells(r).Value = dString
            Else ' The following line may or may not be necessary.
                ' Mistake, clear the complete range before (5 seconds).
                'drg.Cells(r).Clear ' Contents  ' or drg.Cells(r).Clear
                ' Huge mistake, use clear instead (40 seconds).
                'drg.Cells(r).Value = Empty
                'drg.Cells(r).Value = vbNullString
            End If
        End If
    Next r
 
    ' Turn on application settings.
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
    ' Inform.
    MsgBox "Finished in " & Timer - dt & " seconds.", vbInformation
 
End Sub

Sub PopulateRandomData()
    
    Const rCount As Long = 100000
    
    With ThisWorkbook.Worksheets(1)
        .UsedRange.Clear
        .Range("C:H,M:Q").EntireColumn.Hidden = True
        With .Range("A2").Resize(rCount)
            .Cells(1).Offset(-1).Value = "LrCol"
            .Value = .Worksheet.Evaluate("ROW(1:" & CStr(rCount + 1) & ")")
            .EntireColumn.AutoFit
        End With
        With .Range("J2").Resize(rCount)
            .Cells(1).Offset(-1).Value = "Criteria1"
            .Formula = "=CHOOSE(RANDBETWEEN(1,2),""Found"",""Not Found"")"
            .Value = .Value
            .EntireColumn.AutoFit
        End With
        With .Range("K2").Resize(rCount)
            .Cells(1).Offset(-1).Value = "Criteria2"
            .Formula = "=CHOOSE(RANDBETWEEN(1,2),""String"","""")"
            .Value = .Value
            .EntireColumn.AutoFit
        End With
        With .Range("S1")
            .Value = "Result No Issue"
            .EntireColumn.AutoFit
        End With
    End With
    
End Sub
user_98140690
Related