Excel VBA исполняющие аварии

Question

У меня есть следующие функции для запуска на большом первенствовать ковчега с 60k строк:

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 Тогда в конце Удалите все, что не соответствует

Проблема с этим кодом, насколько я могу видеть, заключается в том, что он запускает 60 тыс. строк 60 тыс. раз. что приводит к сбою моего сценария. я не уверен, как его улучшить и подумал, что вы, ребята, сможете это увидеть?

Answer 1

Вы сталкиваетесь с этой проблемой из-за неправильного направления - то, что делает строку отличной, не означает, что столбец F имеет «C» или «P», это значения в столбцах «D» и «G» ' совпадение.

Способ подбора состоит в том, чтобы собрать 2 списка строк с каждой отдельной комбинацией «D» и «G» - один для строк с «C» в столбце F и один для строк с «P» в столбец F. Затем пройдите все различные значения для «C» и «match», основанные на отдельной комбинации. Что-то вроде этого (требуется ссылка на 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 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