Excel vba executing crash - vba

Question

I have the following function to run on a large excel ark with 60k rows:
Private Sub mySub()
Dim intRowA As Long
Dim intRowB As Long
Application.ScreenUpdating = False
Range("W1").EntireColumn.Insert
For intRowA = 2 To ActiveSheet.UsedRange.Rows.Count
If Cells(intRowA, 6).Value = "C" Then
For intRowB = 2 To ActiveSheet.UsedRange.Rows.Count
If Cells(intRowB, 6).Value = "P" Then
If Cells(intRowA, 4).Value = Cells(intRowB, 4).Value And Cells(intRowA, 7).Value = Cells(intRowB, 7).Value Then
Cells(intRowA, 23).Value = "Matched"
Cells(intRowB, 23).Value = "Matched"
End If
End If
DoEvents
Next
End If
Next
For intRowA = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
If Cells(intRowA, 23).Value <> "Matched" Then
Rows(intRowA).Delete shift:=xlShiftUp
End If
Next
Range("W1").EntireColumn.Delete
Application.ScreenUpdating = True
End Sub
The idea to check where F columns are C and match them up with all F
Rows that are value P Then at the end Delete all that does not match
The problem with this code as far as i can see is that it runs the 60k rows 60K times. which makes my script crash. i am unsure how to improve it and thought that you guys might be able to see through this?

Answer 1

You're coming at this problem from the wrong direction - what makes a row distinct isn't whether column F has a 'C' or a 'P', it's whether the values in columns 'D' and 'G' match.
The way to approach this is to collect 2 lists of rows with every distinct combination of 'D' and 'G' - one for rows with a 'C' in column F and one for rows with a 'P' in column F. Then, go through all of the distinct values for the 'C's and match based on the distinct combination. Something like this (requires a reference to Microsoft Scripting Runtime):
Private Sub mySub()
Dim sheet As Worksheet
Dim c_rows As Dictionary
Dim p_rows As Dictionary
Set sheet = ActiveSheet
Set c_rows = New Dictionary
Set p_rows = New Dictionary
Dim current As Long
Dim key As Variant
'Collect all of the data based on keys of columns 'D' and 'G'
For current = 2 To sheet.UsedRange.Rows.Count
key = sheet.Cells(current, 4) & vbTab & sheet.Cells(current, 7)
'Stuff the row in the appropriate dictionary based on column 'F'
If sheet.Cells(current, 6).Value = "C" Then
If Not c_rows.Exists(key) Then
c_rows.Add key, New Collection
End If
c_rows.Item(key).Add current
ElseIf sheet.Cells(current, 6).Value = "P" Then
If Not p_rows.Exists(key) Then
p_rows.Add key, New Collection
End If
p_rows.Item(key).Add current
End If
Next current
sheet.Range("W1").EntireColumn.Insert
'Now filter out the matching Ps that have keys in the C Dictionary:
For Each key In c_rows.Keys
If p_rows.Exists(key) Then
Dim match As Variant
For Each match In p_rows(key)
sheet.Cells(match, 23).Value = "Matched"
Next
End If
Next key
For current = sheet.UsedRange.Rows.Count To 2 Step -1
If sheet.Cells(current, 23).Value = "Matched" Then
sheet.Rows(current).Delete xlShiftUp
End If
Next
sheet.Range("W1").EntireColumn.Delete
End Sub

Answer 2

I agree it is the 60k x 60k loop causing the issue. You can make the loop more efficient a few different ways:
1) Run through the loop and delete all rows where column F doesn't equal C or P beforehand. This may solve the issue outright if there aren't that many rows that contain C or P.
2) Loop through all the rows once and store the necessary row numbers in an array or collection. Then do whatever you need done with the rows separately. For example:
Dim intRow As Long
Dim cCollection As New Collection
Dim pCollection As New Collection
For intRow = 2 To ActiveSheet.UsedRange.Rows.Count
If Cells(intRow, 6).Value = "C" Then
cCollection.Add (intRow)
ElseIf Cells(intRow, 6).Value = "P" Then
pCollection.Add (intRow)
End If
Next
Dim i As Integer
For i = 1 To cCollection.Count
' do something with cCollection(i)
Next
' multiple ways to loop through the collection...
Dim r As Variant
For Each r In pCollection
'do something with pCollection(r)
Next r