Excel VBA执行崩溃

我有以下function在60k行的大型excel柜上运行：

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是否有'C'或'P'，而是'D'和'G'列中的值是否匹配。

解决这个问题的方法是收集两行“D”和“G”不同组合的行列表 – 一列是F列的“C”行，另一列是F列的“P”行。 ，通过“C”的所有不同的值并根据不同的组合进行匹配。 像这样的东西（需要引用Microsoft脚本运行时）：

 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