Sluggish Loop

[breynolds0431]

Hello. I have a loop that goes through around 200,000 rows and needs to transpose some results to a separate sheet, effectively making the data columnar. This seems to take quite a long time. All of the source data is in column A, so there aren't any nested loops where multiple columns need to be evaluated.

Here's what the below does (slowly).... Goes through column A's cells looking for one of two prefixes - either a "IST" or a "CLT". If either cells are found, the nested loop will start to look for the next occurrence of a cell beginning with "CLT". There are some minor differences in how the range is determined for each, which is why they are separate IF statements. However, each will take the range that's found and transpose the results to the next open row on the "results" tab. Any ideas on a more efficient method? I wouldn't think 200k rows would be this slow, but I'm thinking that it's all due to the transpose paste.

Sub testsplit()

Dim nSht As Worksheet: Set nSht = ActiveSheet
Dim oWS As Worksheet: Set oWS = Sheets("results")
Dim c As Range, ce As Range
Dim iLR As Long: iLR = nSht.Cells(nSht.Rows.Count, 1).End(xlUp).row
Dim oLR As Long
Dim bRow As Long, eRow As Long

For Each c In nSht.Range("A1:A" & iLR).Cells

'Determines first row on oWS (results)
If oWS.Cells(1, 1) = "" Then
    oLR = 1
Else
    oLR = oWS.Cells(oWS.Rows.Count, 1).End(xlUp).row + 1
End If

    If Left(c.Value, 3) = "IST" Then
        'Set beginning row to current c row
        bRow = c.row
        
        'now find next row for range to copy, will take ending row -1 to not pick up actual CLT row
        For Each ce In nSht.Range("A" & bRow & ":A" & iLR).Cells
            If Left(ce.Value, 3) = "CLT" Then
                eRow = ce.row - 1
                
                With nSht
                    .Range(.Cells(bRow, 1), .Cells(eRow, 1)).Copy
                    oWS.Cells(oLR, 1).PasteSpecial Transpose:=True
                End With
                'next row found, so the ce for can exit
                Exit For
            End If
        Next ce
    End If
    
    If Left(c.Value, 3) = "CLT" Then
       'Set beginning row to current c row
        bRow = c.row 
        
        'now find next row for range to copy
        'note that bRow is added to 1 so c.row isn't considered next occurance
        For Each ce In nSht.Range("A" & bRow + 1 & ":A" & iLR).Cells
            If Left(ce.Value, 3) = "CLT" Then
                eRow = ce.row
                
                With nSht
                    .Range(.Cells(bRow, 1), .Cells(eRow, 1)).Copy
                    oWS.Cells(oLR, 1).PasteSpecial Transpose:=True
                End With
                'next row found, so the ce for can exit
                Exit For
            End If
        Next ce
    End If
Next c

End Sub

 

[offthelip]

One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.

So instead of writing a loop which loops down a range checking one row at a time in a double loop which will take along time if you have got 200000 rows, it is much quicker to load the 200000 lines into a variant array ( one worksheet access), then do all the checking on the variant array, I have modified your code in a very simple ( only the first half) do do exactly that, this should make the code much much faster.

Sub testsplit()

Dim nSht As Worksheet: Set nSht = ActiveSheet
Dim oWS As Worksheet: Set oWS = Sheets("results")
Dim c As Range, ce As Range
Dim iLR As Long: iLR = nSht.Cells(nSht.Rows.Count, 1).End(xlUp).Row
Dim oLR As Long
Dim bRow As Long, eRow As Long
Dim inarr As Variant
inarr = nSht.Range("A1:A" & iLR)
'For Each c In nSht.Range("A1:A" & iLR).Cells
 For i = 1 To iLR
'Determines first row on oWS (results)
If oWS.Cells(1, 1) = "" Then
    oLR = 1
Else
    oLR = oWS.Cells(oWS.Rows.Count, 1).End(xlUp).Row + 1
End If

'    If Left(c.Value, 3) = "IST" Then
    If Left(inarr(i, 1), 3) = "IST" Then
        
        'Set beginning row to current c row
'        bRow = c.Row
        bRow = i
        
        'now find next row for range to copy, will take ending row -1 to not pick up actual CLT row
'        For Each ce In nSht.Range("A" & bRow & ":A" & iLR).Cells
        For j = bRow To iLR
            If Left(inarr(j, 1), 3) = "CLT" Then
                eRow = j - 1
                
                With nSht
                    .Range(.Cells(bRow, 1), .Cells(eRow, 1)).Copy
                    oWS.Cells(oLR, 1).PasteSpecial Transpose:=True
                End With
                'next row found, so the ce for can exit
                Exit For
            End If
        Next ce
    End If
 ' change this in exactly the same way
 '
 '   If Left(c.Value, 3) = "CLT" Then
 '      'Set beginning row to current c row
 '       bRow = c.Row
 '
 '       'now find next row for range to copy
 '       'note that bRow is added to 1 so c.row isn't considered next occurance
 '       For Each ce In nSht.Range("A" & bRow + 1 & ":A" & iLR).Cells
 '           If Left(ce.Value, 3) = "CLT" Then
 '               eRow = ce.Row
 '
 '               With nSht
 '                   .Range(.Cells(bRow, 1), .Cells(eRow, 1)).Copy
 '                   oWS.Cells(oLR, 1).PasteSpecial Transpose:=True
 '               End With
 '               'next row found, so the ce for can exit
 '               Exit For
 '           End If
 '       Next ce
 '   End If
Next c

End Sub

If you want to make it even faster you can do the same sort of thing with the output, instead copying each section as a range copy , copy from the variant array to a new empty variant array then just paste the new variant array to worksheet once all sections have been copied. two accesses to the worksheet for the whole process probably only a couple of seconds for 200000 rows

I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.

 

[breynolds0431]

Great information. Thank you. I updated first only putting the loop range into the array but that still took some time. After putting the copy range into the array, I saw significant improvement - from 10 minutes down to only a minute.

Here's what I ended up with:

Sub testsplit()

Dim nSht As Worksheet: Set nSht = ActiveSheet
Dim oWS As Worksheet: Set oWS = Sheets("results")
Dim c As Range, ce As Range
Dim iLR As Long: iLR = nSht.Cells(nSht.Rows.Count, 1).End(xlUp).row
Dim oLR As Long
Dim bRow As Long, eRow As Long
Dim inarr As Variant: inarr = nSht.Range("A1:A" & iLR + 1) 'Including additional row for CLT to CLT IF
Dim cpyArr As Variant

Application.ScreenUpdating = False

For i = 1 To iLR

    'Determines first row on oWS (results)
    If oWS.Cells(1, 1) = "" Then
        oLR = 1
    Else
        oLR = oWS.Cells(oWS.Rows.Count, 1).End(xlUp).row + 1
    End If

    If Left(inarr(i, 1), 3) = "IST" Then
        
        bRow = i

        For j = bRow To iLR
            If Not inarr(j, 1) = "" And Left(inarr(j, 1), 3) = "CLT" Then
                eRow = j - 1
                cpyArr = nSht.Range(nSht.Cells(bRow, 1), nSht.Cells(eRow, 1))
                oWS.Range(oWS.Cells(oLR, 1), oWS.Cells(oLR, eRow - bRow + 1)) = Application.Transpose(cpyArr)
                Exit For
            End If
        Next j
    End If
 
    If Left(inarr(i, 1), 3) = "CLT" Then

        bRow = i
        
        For j = bRow To iLR
            If Not inarr(j + 1, 1) = "" And Left(inarr(j + 1, 1), 3) = "CLT" Then
                eRow = j
                cpyArr = nSht.Range(nSht.Cells(bRow, 1), nSht.Cells(eRow, 1))
                oWS.Range(oWS.Cells(oLR, 1), oWS.Cells(oLR, eRow - bRow + 1)) = Application.Transpose(cpyArr)
                Exit For
            End If
        Next j
    End If
Next i

Application.ScreenUpdating = True

End Sub

 

[offthelip]

You might save a bit more time by avoiding anotehr access to the NSht by changing this line:

cpyArr = nSht.Range(nSht.Cells(bRow, 1), nSht.Cells(eRow, 1))

to this code, which loads the array from the original variant array Inarr) which already has all the values

'cpyarr = nSht.Range(nSht.Cells(bRow, 1), nSht.Cells(eRow, 1)) change this to
leneb = eRow - bRow
ReDim cpyarr(1 To leneb, 1 To 1)
For kk = 1 To leneb
cpyarr(kk, 1) = inarr(kk + eRow - 1, 1)
Next kk

Do you know what the maximum width of columns you might ever get, because the really fast way is to remove the line that writes the data to ows sheet and put that outside to loop, this can be done if we know what size array to define for the output is

 

[breynolds0431]

I couldn't quite get the above to work. The IST row wasn't being picked up and the CLT rows weren't aligning correctly. I'll take another stab at it.

For the columns, that was something else I was going to ask. The column count would be variable. Looks like for assigning the range to an array, the last column would need to be known. I was going to update another nested loop with your advice, but each row has a variable amount of columns with data. The other loop I have needs to check the value in the first column and then determine how to proceed with what to look for in the adjacent columns. Seems like a new array would need to be established for each row, but maybe I'm missing the point.

 

[offthelip]

The way I would do it is:
1: Find the maximun column width in the initial data
2: Redim an output array (1 to ilr, 1 to maxcolumns)
3: In the loop where you are copying, copy the input array directly in to the correct row in the output array until you get th the endrow, at this point reset the output column to 1 and increment the row count inthe output array, something likethis:

colno = 1
        For j = bRow To iLR
            If Left(inarr(j, 1), 3) = "CLT" Then
            oLR = oLR + 1
            colno = 1
            Exit For
            Else
            outputarray(oLR, colno) = inarr(j, 1)
            colno = colno + 1
            End If
       Next j

then write the entire output array to the outpuworksheet in one write after all the loops have finished