Excel 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