Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1276to1280
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Code optimieren bzw. beschleunigen

Code optimieren bzw. beschleunigen
Charly
Guten Abend
Könnte mir jemand helfen den folgenden Code zu verbessern bzw. zu beschleunigen?

Sub Act()
Dim lngStart, lngLast, i, z As Long
Dim rngZelle As Range
Application.ScreenUpdating = 0
lngStart = Sheets("Formular").Index + 1
lngLast = Sheets("LV").Cells(Rows.Count, 1).End(xlUp).Row
With Sheets("LV")
.Range("I1,K1,P1,M1:N1,H2:P2000").ClearContents
.Range("A1:N2000").Font.ColorIndex = xlAutomatic
.Range("A1:N2000").Interior.ColorIndex = xlNone
.Range("O2:P2000,P1").Font.Color = RGB(255, 255, 255)
'Werte ins LV eintragen
For i = lngStart To Sheets.Count
For z = 2 To lngLast
If .Cells(z, 1) = Sheets(i).Cells(9, 32) And Sheets(i).Cells(5, 33) = 1 Then _
.Cells(z, 8) = Sheets(i).Cells(23, 12)
If .Cells(z, 1) = Sheets(i).Cells(9, 32) And Sheets(i).Cells(5, 33) = 2 Then _
.Cells(z, 10) = Sheets(i).Cells(23, 12)
If .Cells(z, 1) = Sheets(i).Cells(9, 32) And Sheets(i).Cells(5, 33) = 3 Then _
.Cells(z, 12) = Sheets(i).Cells(23, 12)
Next z
Next i
'Formeln eintragen
'Summe LV"
.Cells(1, 7).FormulaLocal = "=SUMME(G2:G" & lngLast & ")"
'Nr. 1
.Range(.Cells(2, 9), .Cells(lngLast, 9)).FormulaLocal = "=$H2*$F2"
.Cells(1, 9).FormulaLocal = "=SUMME(I2:I" & lngLast & ")"
'Nr. 2
.Range(.Cells(2, 11), .Cells(lngLast, 11)).FormulaLocal = "=$J2*$F2"
.Cells(1, 11).FormulaLocal = "=SUMME(K2:K" & lngLast & ")"
'Nr. 3
.Range(.Cells(2, 13), .Cells(lngLast, 13)).FormulaLocal = "=$L2*$F2"
.Cells(1, 13).FormulaLocal = "=SUMME(M2:M" & lngLast & ")"
'Summe Betrag - Abgerechnet Nr.1 - Nr.2 - Nr.3
.Range(.Cells(2, 14), .Cells(lngLast, 14)).FormulaLocal = "=($I2+$K2+$M2)"
.Cells(1, 14).FormulaLocal = "=SUMME(N2:N" & lngLast & ")"
'Formel zum Filtern
.Range(.Cells(2, 15), .Cells(lngLast, 15)).FormulaLocal = _
"=WENN(($H2+$J2+$L2)=0;""Nicht"";WENN((I2+K2+M2)>G2;""Positiv"";WENN((I2+K2+M2)=G2;""Null" _
" _
;WENN((I2+K2+M2)0;($H2+$J2+$L2)=  _
_
0);$G2;"""")"
.Cells(1, 16).FormulaLocal = "=SUMME(P2:P" & lngLast & ")"
'Formatieren
.Range("G1,N1").Interior.Color = RGB(200, 200, 200)
For i = 2 To lngLast
If .Range("O" & i) = "Positiv" Then .Range(.Cells(i, 1), .Cells(i, 14)).Interior. _
Color = RGB(200, 255, 200)
If .Range("O" & i) = "Negativ" Then .Range(.Cells(i, 1), .Cells(i, 14)).Interior. _
Color = RGB(255, 200, 200)
If .Range("O" & i) = "Null" Then .Range(.Cells(i, 1), .Cells(i, 14)).Font.Color = RGB( _
_
0, 0, 255)
If .Range("O" & i) = "Nicht" Then .Range(.Cells(i, 1), .Cells(i, 14)).Font.Color =  _
RGB(0, 0, 0)
Next
'Formeln in Werte
.Range("A1:P" & lngLast).Value = .Range("A1:P" & lngLast).Value
End With
'Formular aktualisieren
With Sheets("Formular")
.Unprotect
.Cells(18, 38) = Sheets("LV").Range("G1") 'LV Summe
.Cells(20, 38) = Sheets("LV").Range("I1") 'Abger. Nr.1
.Cells(21, 38) = Sheets("LV").Range("K1") 'Abger. Nr.2
.Cells(22, 38) = Sheets("LV").Range("M1") 'Abger. Nr.3
.Cells(18, 39) = .Cells(20, 38) + .Cells(21, 38) + .Cells(22, 38) 'Summe Abgerechnet
.Cells(23, 38) = Sheets("LV").Range("P1") 'Summe nicht Abgerechnet
.Cells(24, 38) = Sheets("LV").Range("N1") + Sheets("LV").Range("P1") 'Summe Abgerechnet + _
_
Summe nicht Abgerechnet
'Formatierung Differenz
If .Range("AL19")  0 Then .Range("AL19:AM19").Interior.Color = RGB(150, 255, 180)
If .Range("AL19") = 0 Then .Range("AL19:A19").Interior.Color.Index = xlNone
.Protect
End With
End Sub

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Code optimieren bzw. beschleunigen
14.09.2012 01:09:53
fcs
Hallo Charly,
deaktiviere nicht nur die Bildschirmaktualisierung zu Beginn des Makros sondern setze auch den Berechnungsmodus auf manuell
Application.Calculation = xlCalculationManual
Nach dem Einfügen der Formeln setzt du ihn dann wieder auf automatisch.
Application.Calculation = xlCalculationAutomatic
Gruß
Franz

AW: Code optimieren bzw. beschleunigen
14.09.2012 04:49:40
Charly
Hallo Franz
Danke für den Tipp.
Hilft aber nicht.
Ich sehe erst jetzt, dass der Code abgeschnitten ist.
Nach dem einfügen der Formeln folgt
.Range("A1:P" & lngLast).Value = .Range("A1:P" & lngLast).Value
Ich stelle die Frage mal anders.
Kann mann diese Stelle im Code anders schreiben?
Ab ca. 150 Sheets wirds ziemlich langsam.
lngStart = Sheets("Formular").Index + 1
lngLast = Sheets("LV").Cells(Rows.Count, 1).End(xlUp).Row
With Sheets("LV")
For i = lngStart To Sheets.Count
For z = 2 To lngLast
If .Cells(z, 1) = Sheets(i).Cells(9, 32) And Sheets(i).Cells(5, 33) = 1 Then _
.Cells(z, 8) = Sheets(i).Cells(23, 12)
If .Cells(z, 1) = Sheets(i).Cells(9, 32) And Sheets(i).Cells(5, 33) = 2 Then _
.Cells(z, 10) = Sheets(i).Cells(23, 12)
If .Cells(z, 1) = Sheets(i).Cells(9, 32) And Sheets(i).Cells(5, 33) = 3 Then _
.Cells(z, 12) = Sheets(i).Cells(23, 12)
Next z
Next i
Danke vorab.
MfG Charly

Anzeige
AW: Code optimieren bzw. beschleunigen
14.09.2012 07:37:49
fcs
Hallo Charly,
Mit folgender Anpassung sollte es schneller gehen, da wahrscheinlich der 2. Teil der Prüfungen nicht in jeder Zeile durchlaufen und die Anzahl der Zugriffe auf Tabellendaten reduziert wird.
Bildschirmaktualisieren-deaktivieren und Berechnung auf manuell solltest du trotzdem umsetzen. Falls die Tabelle, in der das Makro Werte einfügt, auch noch Ereignismakros hat, dann muss du diese ebenfalls deaktivieren. Diese 3 Einstellungen sind die absoluten Makro-Beschleuniger.
Als extreme Massnahme könnte man die Daten in den Spalten 1, 8, 10 und 12 des Blatts "LV" in Datenarray(s) einlesen und nach den Änderungen zurückschreiben. Da kann ich aber nicht Einschätzen wieviel das noch bringt. Das dürfte sich aber lohnen, wenn das LV mehrere 1000 Zeilen hat.
Aber gegen Masse hilft halt nur Abwarten und Tee-/kaffetrinken.
Gruß
Franz

Dim lngstart&, lngLast&, i&, Z&, vWert1, vWert2, vWert3
lngstart = Sheets("Formular").Index + 1
lngLast = Sheets("LV").Cells(Rows.Count, 1).End(xlUp).Row
With Sheets("LV")
For i = lngstart To Sheets.Count
vWert1 = Sheets(i).Cells(9, 32)
vWert2 = Sheets(i).Cells(5, 33)
vWert3 = Sheets(i).Cells(23, 12)
For Z = 2 To lngLast
If .Cells(Z, 1) = vWert1 Then
Select Case vWert2
Case 1: .Cells(Z, 8) = vWert3
Case 2: .Cells(Z, 10) = vWert3
Case 3: .Cells(Z, 12) = vWert3
End Select
End If
Next Z
Next i
End With

Anzeige
AW: Code optimieren bzw. beschleunigen
14.09.2012 08:13:01
Charly
Danke Franz,
dass bringt schon einen Geschwindigkeitsvorteil.
Das LV kann bis zu 2000 Zeilen haben.
Im Moment teste ich mit 170 Zeilen.
Wenn du nochmal Zeit hast, könntest du mir die extreme Maßnahme (in Datenarray(s) einlesen) realisieren?
Ich würde das gern mal probieren.
Danke vorab.
Ich lasse die Frage mal offen.
MfG Charly

AW: Code optimieren bzw. beschleunigen
14.09.2012 10:11:09
fcs
Hallo Charly,
hier die Variante mit Arrays.
Geschwindigkeitsgewinn irgendwo zwischen 5 und 10.
Gruß
Franz
Sub aaTestNeu()
Dim lngstart&, lngLast&, i&, Z&, vWert1, vWert2, vWert3
Dim arr01, arr08, arr10, arr12
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
lngstart = Sheets("Formular").Index + 1
With Sheets("LV")
lngLast = .Cells(.Rows.Count, 1).End(xlUp).Row
arr01 = .Range(.Cells(1, 1), .Cells(lngLast, 1))
arr08 = .Range(.Cells(1, 8), .Cells(lngLast, 8))
arr10 = .Range(.Cells(1, 10), .Cells(lngLast, 10))
arr12 = .Range(.Cells(1, 12), .Cells(lngLast, 12))
For i = lngstart To Sheets.Count
vWert1 = Sheets(i).Cells(9, 32)
vWert2 = Sheets(i).Cells(5, 33)
vWert3 = Sheets(i).Cells(23, 12)
For Z = 2 To lngLast
If arr01(Z, 1) = vWert1 Then
Select Case vWert2
Case 1: arr08(Z, 1) = vWert3
Case 2: arr10(Z, 1) = vWert3
Case 3: arr12(Z, 1) = vWert3
End Select
End If
Next Z
Next i
.Range(.Cells(1, 1), .Cells(lngLast, 1)) = arr01
.Range(.Cells(1, 8), .Cells(lngLast, 8)) = arr08
.Range(.Cells(1, 10), .Cells(lngLast, 10)) = arr10
.Range(.Cells(1, 12), .Cells(lngLast, 12)) = arr12
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
Erase arr01, arr08, arr10, arr12
MsgBox "Fertig"
End Sub
End Sub

Anzeige
Danke ...
14.09.2012 10:40:51
Charly
... Franz,
dass ist optimal.
Vielen Dank nochmal, dass hilft mir sehr viel weiter.
Schönes WE
MfG Charly

286 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige