VBA Makro läuft sehr lange, kann hier optimiert werden?

Question

Hallo,

ich habe ein Makro am Laufen, welches mir 21 Zellen pro Zeile vollgepackt mit Formeln bis ans Ende der Liste kopiert, final dann jeweils die Werte einfügt.

Es sollen nur die Werte in den Zellen stehen, damit die Datei nicht träge wird.

Jetzt ist es aber so, dass die Laufzeit des Makros für die 121.000 Zeile 87 Minuten beträgt :-(

Gibt es im folgenden Makro Optimierungsmöglichkeiten, welche die Laufzeit des Makros verkürzen könnte?

Sub KopierenUndWerteEinfügen()
Dim lngLetzte As Long
Dim Bereich As Variant
Application.ScreenUpdating = False
lngLetzte = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row - 4
    For i = 1 To lngLetzte
    Range(Cells(4, 30), Cells(4, 50)).Copy Cells(4 + i, 30)     ' Für Formate einfügen
    Range(Cells(4 + i, 30), Cells(4 + i, 50)).Copy
    Cells(4 + i, 30).PasteSpecial Paste:=xlValues               ' Werte einfügen
    Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.Calculate
End Sub

Bin für jeden Hinweis dankbar!

K.

Answer 1

Hallo K.,

ich kenne mich mit der Makroprogrammierung nicht wirklich aus. Aber könnte das Ausschalten der automatischen Berechnung vor Start des Makros helfen? Du schaltest sie nach Ende des Makros zwar wieder ein, ich sehe aber das Ausschalten nicht.

Application.Calculation = xlManual

Gruß computerschrat

Answer 2

Hallo,

da ausgehend von Zeile 4 die Formeln in jede Zeile einzeln kopiertcwerden kann ich die Berechnung nicht ausschalten.

Das Einschalten am Ende ergibt zwar sogesehen auch keinen Sinn...

Answer 3

Probiere es mit dem Autofilter(Bereiche benennen oder Bereichsnamen) und greife dann auf den sichtbaren Bereich deines zuvor angegebenen Bereiches/Bereichsname zuzu!

Ein Array wäre halbherig da es nur Werte aufnimmt und keine Formate!

Für Bereiche Objekte mit Set erstellen

Variablen deklatieren ,Option Explicit nutzen!

Answer 4

Du könntest das aber in zwei getrennte Schleifen aufteilen. In der ersten kopierst du Formel und Format bei ausgeschalteter Neuberechnung. Dann lässt du einmal neu berechnen und kopierst in einer neuen Schleife auch wieder ohne automatische Berechnung die Werte.

Gruß computerschrat

Answer 5

Hi ihr Beiden.

Den zweiten Vorschlag von Computerschrat wollte ich auch schon anbringen. Allerdings wird die Neuberechnung von 2,5 Mio. Formeln trotzdem sehr lange dauern. Vielleicht sogar wesentlich länger als bisher. Insofern ist deine Herangehensweise schon mal nicht schlecht, immer nur eine Zeile zu berechnen und dann zu fixieren.

Aber: Copy und Paste dauert auch seine Zeit. Ein ganzes Stück schneller sollte es gehen wenn du die Werte direkt übernimmst:

 Range(Cells(4 + i, 30), Cells(4 + i, 50)).Value =  Range(Cells(4 + i, 30), Cells(4 + i, 50)).Value

Wenn du es noch schneller haben willst, dann verzichte auf den Zeilenweise Zugriff auf das Range-Objekt. Das dauert zwar nur Millisekunden aber mal 121000 kommen da schon einige Minuten zusammen. Versuche daher anstelle der Formeln die Berechnung direkt in VBA durchzuführen. Packe das Ergebnis in ein Eins-basiertes zweidimensionales Array und lade das Array auf einen Schlag in die komplette Liste.

Cells(4 + i, 30).Resize(zeilen, Spalten).Value = arr

Danach sollte das Makro nur noch wenige Sekunden brauchen.

Gruß Mr. K.

Answer 6

Hallo,

nachdem ich die Copy Paste Aktion ausgetauscht habe, und mit .value die Werte direkt geschrieben habe, konnte ich die Zeit halbieren. *immerhin*

Mit dem Array kenn ich mich leider überhaupt nicht aus.

Danke für euren Input!

Answer 7

Hallo,

na das ist doch schon mal was. Jetzt müssen wir nur noch die Range- Zugriffe minimieren. Jede Zeile wird einmal gelesen und einmal geschrieben. Wenn wir die Schreibzeit einsparen, sollte sich das nochmal verbessern. Probier mal, ob das hier was bringt.

Sub KopierenUndWerteEinfügen()
Dim lngLetzte As Long
Dim Bereich As Variant
Dim arr(), arrzei()
Application.ScreenUpdating = False
lngLetzte = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row - 4
ReDim arr(1 To lngLetzte, 1 To 21)
    For i = 1 To lngLetzte
    Range(Cells(4, 30), Cells(4, 50)).Copy Cells(4 + i, 30)     ' Für Formate einfügen
    arrzei = Range(Cells(4 + i, 30), Cells(4 + i, 50))
    Range(Cells(4 + i, 30), Cells(4 + i, 50)).ClearContents
      For k = 1 To 21
        arr(i, k) = arrzei(k - 1)
      Next k
    Next i
    Cells(4 + 1, 30).Resize(lngLetzte, 21).Value = arr
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.Calculate
End Sub

Um noch weitere Einsparungen zu treffen musst du wie gesagt die Formelberechnungen direkt in VBA durchführen. und somit das Copy Paste der Formeln einsparen. Da ich deine Formeln nicht kenne kann ich dir hier aktuell leider nicht weiterhelfen. Aber du kannst hier gern eine Datei mit Beispieldaten hochladen, dann schau ich mir das mal an.

Gruß Mr. K.

Answer 8

Hallo,

es wird ein Laufzeitfehler(9) verursacht,

Index außerhalb des gültigen Bereichs.

In der Zeile

arr(i, k) = arrzei(k - 1)

Answer 9

Mein Fehler! Es muss natürlich heißen: arr(i, k) = arrzei(1, k) Probiers bitte nochmal.

Answer 10

Hallo,

so ganz zufrieden bin ich mit der Lösung noch nicht. Es bringt mein Excel machmal zum Absturz und die Laufzeit ist immer noch annähernd so lange wie bei der vorherigen Optimierung.

Ich habe mich jetzt daran gemacht, die "Rohdaten" zu bereinigen, also mache die Liste kleiner, damit die finale Kopiererei nicht so lange dauert. Dann versuche ich die Array Lösung nochmals, muss ja schneller gehen.

So prüfe ich nun in einem ersten Schritt, ob in Spalte 6, also F zweimal übereinander Text enthalten ist.
Sollte das der Fall sein, kann die obere Zeile gelöscht werden. Ich lasse folgendes Makro über die ganze Liste drüberarbeiten, muss es aber 5-6 mal ausführen um letztendlich alle Zeilen welche die Kriterien erfüllen zu erwischen. Erst nach dem 5-6. mal sind auch wirklich alle Zeilen gelöscht.

Was mache ich da falsch? das muss doch auch beim ersten mal schon alles erwischen?

Sub ZeilenLöschenOhneDaten()
Dim lngLetzte As Long
lngLetzte = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
For i = 4 To lngLetzte
If Application.WorksheetFunction.IsText(Cells(i, 6)) And Application.WorksheetFunction.IsText(Cells(i + 1, 6)) Then
Cells(i, 2).EntireRow.Delete
End If
Next i
End Sub

Danke für eure Mühe!

K.