Excel VBA Absturz aufgrund der Größe

Question

Ich habe ein Skript in VBA, die eine sehr lange Pivot-Tabelle mit über 190.000 Einträge in der Tabelle "Daten" gelesen werden sollte, und entsprechend dem Wert in der Spalte "J" sollte die schreiben Informationen aus dieser Zeile in einem Blatt namens "Temp". Wenn sich der Wert aus der Spalte "A" ändert, sollte er vom Blatt "Regioner" eine Liste von über 600 Einträgen lesen und prüfen, ob jeder Wert in den vorherigen Datenfeldern dargestellt ist. Der Code, den ich schrieb, funktioniert, aber es dauert ewig, die erwarteten 220.000 Einträge in der "Temp" Tabelle aufzuschreiben. In meinem Laptop, i5 6. Generation mit 8 GB RAM, stürzt es einfach ab. Der aktuelle Code ist wie folgt. Vielen Dank an alle!

Public Sub FindWithoutOrder() 

Dim DataRowCounter As Long 
Dim TempRowCounter As Long 
Dim RegiRowCounter As Long 
Dim DataOldCounter As Long 
Dim DataNewCounter As Long 
Dim loopCounter As Long 
Dim DataOldProd As Range 
Dim DataNewProd As Range 
Dim DataPurchase As Range 
Dim RegiButikk As Range 
Dim ButikkFlag As Boolean 

'Code optimization to run faster. 
Application.ScreenUpdating = False 
Application.DisplayAlerts = False 

'Initialize variables. 
'---------------------------------------------------------------------------------------------------------- 
DataRowCounter = 11 
TempRowCounter = 1 
DataOldCounter = 11 
DataNewCounter = 11 
Set DataOldProd = ActiveWorkbook.Sheets("Data").Range("A" & DataRowCounter) 
Set DataNewProd = ActiveWorkbook.Sheets("Data").Range("A" & DataRowCounter) 
Set DataPurchase = ActiveWorkbook.Sheets("Data").Range("J" & DataRowCounter) 

'Start of loop that verifies all values inside "Data" sheet. 
'---------------------------------------------------------------------------------------------------------- 
Do Until (IsEmpty(DataOldProd) And IsEmpty(DataNewProd)) 

    'Verify if the product of new line is still the same or different. 
    '------------------------------------------------------------------------------------------------------ 
    If DataNewProd.Value = DataOldProd.Value Then 
     DataNewCounter = DataNewCounter + 1 
    Else 

     'Initialize variables from "Regioner" sheet. 
     '------------------------------------------------------------------------------------------ 
     ButikkFlag = False 
     RegiRowCounter = 11 
     Set RegiButikk = ActiveWorkbook.Sheets("Regioner").Range("C" & RegiRowCounter) 

     'Verify list of supermarkets and match them with purchases list. 
     '-------------------------------------------------------------------------------------------------- 
     Do Until IsEmpty(RegiButikk) 

      'Check all supermarkets in the product range. 
      '---------------------------------------------------------------------------------------------- 
      For loopCounter = DataOldCounter To DataNewCounter - 1 

       'Compare both entries and register them if it doesn't exist in the product list. 
       '------------------------------------------------------------------------------------------ 
       If RegiButikk.Value = ActiveWorkbook.Sheets("Data").Range("D" & loopCounter).Value Then 
        ButikkFlag = True 
        RegiRowCounter = RegiRowCounter + 1 
        Set RegiButikk = ActiveWorkbook.Sheets("Regioner").Range("C" & RegiRowCounter) 
        Exit For 
       Else 
        ButikkFlag = False 
       End If 

      Next loopCounter 

      'Add to list supermarkets not present in the purchases list. 
      '------------------------------------------------------------------------------------------ 
      If ButikkFlag = False Then 
       ActiveWorkbook.Sheets("Temp").Range("B" & TempRowCounter & ":D" & TempRowCounter).Value = ActiveWorkbook.Sheets("Regioner").Range("A" & RegiRowCounter & ":C" & RegiRowCounter).Value 
       ActiveWorkbook.Sheets("Temp").Range("A" & TempRowCounter).Value = ActiveWorkbook.Sheets("Data").Range("A" & DataRowCounter - 1).Value 
       TempRowCounter = TempRowCounter + 1 
       RegiRowCounter = RegiRowCounter + 1 
       Set RegiButikk = ActiveWorkbook.Sheets("Regioner").Range("C" & RegiRowCounter) 
      End If 

     Loop 

     'Reset the product range. 
     '-------------------------------------------------------------------------------------------------- 
     DataOldCounter = DataNewCounter 
     DataNewCounter = DataNewCounter + 1 

    End If 

    'Validate if item was purchased in the defined period and copy it. 
    '------------------------------------------------------------------------------------------------------ 
    If DataPurchase.Value = 0 Then 
     ActiveWorkbook.Sheets("Temp").Range("A" & TempRowCounter & ":D" & TempRowCounter).Value = ActiveWorkbook.Sheets("Data").Range("A" & DataRowCounter & ":D" & DataRowCounter).Value 
     TempRowCounter = TempRowCounter + 1 
    End If 

    'Update row counter and values for previous and new product readed. 
    '------------------------------------------------------------------------------------------------------ 
    Set DataOldProd = ActiveWorkbook.Sheets("Data").Range("A" & DataRowCounter) 
    DataRowCounter = DataRowCounter + 1 
    Set DataNewProd = ActiveWorkbook.Sheets("Data").Range("A" & DataRowCounter) 
    Set DataPurchase = ActiveWorkbook.Sheets("Data").Range("J" & DataRowCounter) 

Loop 

'Code optimization to run faster. 
Application.ScreenUpdating = True 
Application.DisplayAlerts = True 

End Sub 

Answer 1

Statt alle über den Ort dieser Code verstreut zu haben:

'Code optimization to run faster. 
Application.ScreenUpdating = False 
Application.DisplayAlerts = False 

Verwenden Sie dieses Verfahren:

Public Sub ToggleWaitMode(ByVal wait As Boolean) 
    Application.Cursor = IIf(wait, XlMousePointer.xlWait, XlMousePointer.xlDefault) 
    Application.StatusBar = IIf(wait, "Working...", False) 
    Application.Calculation = IIf(wait, XlCalculation.xlCalculationManual, XlCalculation.xlCalculationAutomatic) 
    Application.ScreenUpdating = Not wait 
    Application.EnableEvents = Not wait 
End Sub 

So:

Public Sub DoSomething() 
    ToggleWaitMode True 
    On Error GoTo CleanFail 

    'do stuff 

CleanExit: 
    ToggleWaitMode False 
    Exit Sub 
CleanFail: 
    'handle errors 
    Resume CleanExit 
End Sub 

automatische Berechnung sperren und Arbeitsblatt Ereignisse sho eld hilft schon ziemlich viel ... aber es "optimiert" nichts. Es macht Excel einfach viel weniger, wenn eine Zelle geändert wird.

Wenn Ihr Code funktioniert, aber nur langsam, nehmen Sie es zu Code Review Stack Exchange und vorhanden es den VBA Rezensenten: sie werden aus ihrer Wege gehen, um Ihnen tatsächlich Ihren Code optimieren. Ich weiß, ich bin einer von ihnen =)