Question

我有以下功能在一个60k行的大型excel ark上运行：

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

检查F列的C在哪里并与所有F匹配的想法值为P的行然后在结尾处删除所有不匹配的行

据我所知，这段代码的问题在于它运行60k行60K次。这使我的脚本崩溃。我不确定如何改进它，并认为你们可能能够看透这个？

Answer 1

你是从错误的方向解决这个问题 - 是什么让一行明显不是列F是否有一个＆＃39; C＆＃39;或者一个＆＃39; P＆＃39;它是否列中的值是＆＃39; D＆＃39;和＆＃39; G＆＃39;匹配。

解决这个问题的方法是收集2个行列表，其中包含＆＃39; D＆＃39; D＆＃39; D＆＃39; D＆＃39;和＆＃39; G＆＃39; - 一个用于＆＃39; C＆＃39;在F列中，一行用于＆＃39; P＆＃39;在F列中。然后，浏览＆＃39; C的所有不同值，并根据不同的组合进行匹配。像这样的东西（需要引用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

我同意这是导致问题的60k x 60k循环。您可以通过几种不同的方式提高循环效率：

1）运行循环并删除列F之前不等于C或P的所有行。如果没有包含C或P的许多行，这可以彻底解决问题。

2）遍历所有行一次，并将必要的行号存储在数组或集合中。然后分别对行执行任何操作。例如：

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

Excel vba执行崩溃

2 个答案: