2

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
5
  • How many rows do you typically have? You could just use an IF(AND()) formula in S. Or perhaps quickly filter by column J? Commented Jun 25, 2022 at 18:40
  • Thanks for your reply. The rows vary, but can be quite a lot, 5000 or more in some cases. Commented Jun 25, 2022 at 18:47
  • 1
    Does this answer your question? Get a filtered range into an array Commented Jun 25, 2022 at 19:01
  • Each . is a function call. By using With ActiveWorkBook you can now omit ActiveWorkBook from inside the loop. So ActiveWorkbook.Sheets(1).Range("J" & i).Value becomes .Sheets(1).Range("J" & i).Value. As you are only using sheet 1 you can do this With ActiveWorkbook.Sheets(1) and omit two function calls per use. Commented Jun 25, 2022 at 20:48
  • Does this answer your question? Put range into an array for more efficient loops Commented Jun 26, 2022 at 9:39

3 Answers 3

1

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.

Sign up to request clarification or add additional context in comments.

Comments

1

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

4 Comments

"You might need to adjust for column headers etc." - definitely. Don't run this with a full column, Range("J:J")
Yeah, I went ahead and added a basic row count as I should have in the first one lol. I think IsEmpty(arr) is better for arrays than arr <> "" as well.
FWIW IsEmpty(arr) does not quite do the same thing as arr <> "". Specifically if the array element is an empty string, (perhaps returned by a formula )
Firstly, thank you immensely for your help @data_sc. I tried the first one you posted, and this was very quick (less than 2 mins to check 40,000 rows). I've also now tried your updated suggestion, and unfortunately this is very slow. Should adding the row count (which is required) have that much of an impact on performance?
0

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

1 Comment

This is a lot of work you've done here! It's very much appreciated!

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.