Thema: Makro zu langsam | Herbers Excel-Forum

Hallo liebe Excelprofis,
habe ein kleines Problem. In meiner Datei gibt es ein Makro das sehr langsam läuft so bald ich mehr als 1000 Datensätze in meiner Tabelle habe. Könnt ihr bitte mal drüber schauen was man an diesem Makro optimieren kann. Teilweise dauert die Ausführung über 5 Minuten. Das ist zu lange. Würde mich sehr über Hilfe freuen.
Gruß
Absolut Beginners René

Private Sub OKBerichtsdaten_Click()
FormularWochenbericht.Hide
Application.ScreenUpdating = False
DatenSortieren
Dim cbxModell As String
Dim Anfang As Date, Ende As Date
'Zusammensetzung des neuen Dateinamens
ExportJahr = Format(Date, "yyyy")
ExportMonat = Format(Date, "mm")
ExportTag = Format(Date, "dd")
txtKW = Format(txtKW, "00") 'wichtig für die ersten 9 kw's im jahr
'Zeitraum für Chart/Statistik
'Bestimmung des Datums, ab dem aktualisiert wird
'Anfang ist auf Grund des Berichtszeitraumes um -3 gegenüber KW-Anfang verschoben
'die letzten 3 kw werden aktualisiert
lkw = Sheets("rechnen").Range("b19").Value 'letzte ausgewertete KW
If CLng(txtJahr & txtKW) >= CLng(lkw) Then  'wenn ne spätere ausgewertet wird
Anfang = anfantikw(Right(lkw, 2) - 1) - 3
Ende = Date
Sheets("rechnen").Range("b19").Value = Year(Date) & txtKW
Anfangsdatum = Worksheets("Daten").Cells(2, 1).Value
If Anfang < Anfangsdatum Then Anfang = Anfangsdatum
Else
SOFE = True   'falls ne ältere kw ausgewertet wird kann das ganze übersprungen werden
End If
Ziel = CDec(nmbZiel)
BerDatum = Date
'Bestimmung des Modells für den ersten Durchlauf der Tagesberichterstellung
cbxModell = "A6"
'tabellenlänge feststellen
lngtab = 1
Do Until Sheets("daten").Cells(lngtab, 1).Value = "": lngtab = lngtab + 1: Loop
For durchlauf = 1 To 3
'On Error GoTo Err_Handler
'Definition des neuen Dateinamens
ExportName = CStr(ExportJahr) + "-" + CStr(ExportMonat) + "-" + CStr(ExportTag) + "  _
Wochenbericht KW" + CStr(txtKW)
berichtsname = "WB_" + cbxModell
'in Tab Berichtsdaten/stats/WB enthaltene Altdaten löschen
Sheets("Berichtsdaten").Cells.ClearContents
Sheets("Stats").Range("A3:G20").ClearContents
Sheets(berichtsname).Range("E5:Q55").ClearContents
With Sheets(berichtsname).Range("E15:Q55")  'linien entfernen falls es mal mehr Fehler gab
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
If SOFE = True Then GoTo SOF 'falls vergange Kw ausgewertet wird datenauszug überspringen
'Berichtsdatenauszug herstellen/ aus Daten in Berichtdaten kopieren
satz = 1
For zeile = 2 To lngtab
aktdatum = CDate(Sheets("daten").Cells(zeile, 1).Value)
If (aktdatum >= Anfang) And (aktdatum <= Ende) And (Sheets("daten").Cells(zeile, 3). _
Value = cbxModell) Then
Sheets("Berichtsdaten").Rows(satz).Value = Sheets("daten").Rows(zeile).Value
satz = satz + 1
End If
Next zeile
'falls es Treffer gab, mit der Berichterstellung beginnen
If satz <= 1 Then
MsgBox "Keine Daten für Modell " & cbxModell & " im Zeitraum " & Anfang & " bis " &  _
Ende & " vorhanden!"
GoTo näxtmodell
End If
'Gruppieren nach Datum
Sheets("Berichtsdaten").Cells.sort _
Key1:=Sheets("Berichtsdaten").Range("A1"), Order1:=xlAscending, _
Key2:=Sheets("Berichtsdaten").Range("D1"), Order2:=xlAscending, _
Key3:=Sheets("Berichtsdaten").Range("K1"), Order3:=xlAscending
'Suchen des Anfangspunktes in der Datenbank FWB_Modell
datensatzzeiger = 2
Do Until Sheets("FWB_" + cbxModell).Cells(datensatzzeiger, 1) = "" Or Sheets("FWB_" +  _
cbxModell).Cells(datensatzzeiger, 1) >= Anfang
datensatzzeiger = datensatzzeiger + 1
Loop
zeiger = 0
tmp = 1
'Start der Ausgabereihe in FWB an der richtigen Stelle
'daten aus berichtsdaten in FWB kopieren
länge = satz
satz = datensatzzeiger
Sheets("FWB_" + cbxModell).Visible = True
For zeile = 1 To länge - 1
aktdatum = CDate(Sheets("Berichtsdaten").Cells(zeile, 1).Value)
Fehlerart = Sheets("Berichtsdaten").Cells(zeile, 11).Value
VerursacherKonzern = Sheets("Berichtsdaten").Cells(zeile, 16).Value
If zeile = 1 Then
For xx = 1 To 9: Sheets("FWB_" + cbxModell).Cells(satz, xx).ClearContents: Next
GoTo 3:
End If
'Prüfen, ob der vorherige Datensatz vom gleichen Tag ist
If (Sheets("Berichtsdaten").Cells(zeile - 1, 1).Value = aktdatum) Then
'Zähle Anzahl Autos
'Falls das Auto mehrmals geprüft wurde, die Anzahl der Autos NICHT erhöhen
If Sheets("Berichtsdaten").Cells(zeile - 1, 4).Value = Sheets("Berichtsdaten"). _
Cells(zeile, 4).Value Then
tmp = 0
Else
tmp = 1
End If
Else
satz = satz + 1
tmp = 1
Sheets("FWB_" + cbxModell).Select
Rows(satz - 1).Copy
Rows(satz).Select
Cells(satz, 1).Select
ActiveSheet.Paste
For xx = 1 To 9: Sheets("FWB_" + cbxModell).Cells(satz, xx).ClearContents: Next
End If
3:
'Wechseln in das Datenbanksheet
If Sheets("FWB_" + cbxModell).Cells(satz, 12).Value = "" Then
Sheets("FWB_" + cbxModell).Select
Rows(satz - 1).Copy
Rows(satz).Select
Cells(satz, 1).Select
ActiveSheet.Paste
For xx = 1 To 9: Sheets("FWB_" + cbxModell).Cells(satz, xx).ClearContents: Next
End If
Sheets("FWB_" + cbxModell).Cells(satz, 1).Value = aktdatum
'Anzahl der geprüften Fahrzeuge ggf. um eins erhöhen
Sheets("FWB_" + cbxModell).Cells(satz, 2).Value = Sheets("FWB_" + cbxModell).Cells(satz, _
_
2).Value + tmp
'Zählen der Fehlerarten
Select Case Fehlerart
Case Is = "LB": Sheets("FWB_" + cbxModell).Cells(satz, 3).Value = Sheets("FWB_" +   _
_
cbxModell).Cells(satz, 3).Value + 1: _
Case Is = "A": Sheets("FWB_" + cbxModell).Cells(satz, 8).Value = Sheets("FWB_" +  _
cbxModell).Cells(satz, 8).Value + 1
Case Is = "B": Sheets("FWB_" + cbxModell).Cells(satz, 9).Value = Sheets("FWB_" +  _
cbxModell).Cells(satz, 9).Value + 1
End Select
'Falls es sich um einen Liegenbleiber handelt, dann auch den KonzernVerursacher zählen
If Fehlerart = "LB" Then
Select Case Sheets("berichtsdaten").Cells(zeile, 15).Value
Case Is = "Montage": Sheets("FWB_" + cbxModell).Cells(satz, 4).Value = Sheets("  _
_
FWB_" + cbxModell).Cells(satz, 4).Value + 1
Case Is = "Lieferant": Sheets("FWB_" + cbxModell).Cells(satz, 5).Value = Sheets( _
_
"FWB_" + cbxModell).Cells(satz, 5).Value + 1
Case Is = "Hausteile": Sheets("FWB_" + cbxModell).Cells(satz, 6).Value = Sheets( _
_
"FWB_" + cbxModell).Cells(satz, 6).Value + 1
Case Is = "Konstruktiv": Sheets("FWB_" + cbxModell).Cells(satz, 7).Value =  _
Sheets("FWB_" + cbxModell).Cells(satz, 7).Value + 1
End Select
End If
Next
'Entfernen von evtl. nachstehenden Datensätzen
satz = satz + 1
While Sheets("FWB_" + cbxModell).Cells(satz, 1).Value <> ""
Sheets("FWB_" + cbxModell).Rows(satz).ClearContents
satz = satz + 1
Wend
'Rechtsverschieben der alten Zielvorgaben, falls eine neue KW
If CInt(txtKW) = CInt(Range("D2").Value) + 1 Then
Sheets("DWB_" + cbxModell).Range("F11").Value = Sheets("DWB_" + cbxModell).Range("E11"). _
_
Value
Sheets("DWB_" + cbxModell).Range("E11").Value = Sheets("DWB_" + cbxModell).Range("D11"). _
_
Value
Sheets("DWB_" + cbxModell).Range("D11").Value = Sheets("DWB_" + cbxModell).Range("C11"). _
_
Value
End If
'Fehlerarten eintragen
'Altes Ergebnis Löschen
SOF:
'Einsetzen der neuen Werte des Wochenberichts
Sheets("DWB_" + cbxModell).Range("C11").Value = CDec(Ziel)
Sheets("DWB_" + cbxModell).Range("D2").Value = CInt(txtKW)
Sheets("DWB_" + cbxModell).Range("E2").Value = CInt(txtJahr)
Sheets("Berichtsdaten").Cells.ClearContents
'Berichtsdatenauszug herstellen
modell = 1
satz = 1
'--> Anfang der AuswertungsKW = Freitag; Verschiebung durch Auswertungszeitraum ( _
Donnerstags), wird aus Tabellenblatt ausgelesen
Start_KW = Anfang_Kalenderwoche(CInt(txtJahr), CInt(txtKW)) + Worksheets("DWB_" + cbxModell) _
_
.Cells(2, 14).Value
Ende_KW = Start_KW + 6
For zeile = 2 To lngtab - 1
If Sheets("Daten").Cells(zeile, 1).Value = "" Then Exit For
aktdatum = CDate(Sheets("Daten").Cells(zeile, 1).Value)
'Diesmal nur Daten EINER KW kopieren
If (aktdatum >= Start_KW) And (aktdatum <= Ende_KW) And _
(Sheets("Daten").Cells(zeile, 3).Value = cbxModell) And _
(Sheets("Daten").Cells(zeile, 11).Value <> "C") And _
(Sheets("Daten").Cells(zeile, 11).Value <> "0") And _
(Sheets("Daten").Cells(zeile, 11).Value <> "") Then
Sheets("Berichtsdaten").Rows(satz).Value = Sheets("Daten").Rows(zeile).Value
satz = satz + 1
End If
Next
'###########Beschreibungen einfügen
If satz > 1 Then
Sheets("Berichtsdaten").Cells.sort _
Key1:=Sheets("Berichtsdaten").Range("Q1"), Order1:=xlDescending, _
Key2:=Sheets("Berichtsdaten").Range("K1"), Order2:=xlAscending, _
Key3:=Sheets("Berichtsdaten").Range("O1"), Order3:=xlAscending
satz = satz - 1
'Start der Ausgabereihe
tmp = 0
kopieren_ab = 14
zeile = 5
For lv = 1 To satz
If Sheets("Berichtsdaten").Cells(lv, 1).Value = "" Then Exit For
Spezifikation = Sheets("Berichtsdaten").Cells(lv, 17).Value
Fehlerart = CStr(Sheets("Berichtsdaten").Cells(lv, 11).Value)
Verursacher = Sheets("Berichtsdaten").Cells(lv, 12).Value
Bemerkung = Sheets("Berichtsdaten").Cells(lv, 18).Value
Maßnahme = Sheets("Berichtsdaten").Cells(lv, 19).Value
If lv > 1 Then
'Gruppieren nach Fehlerspezifikation, falls Spezifikation, Fehlerart und Verursacher ü  _
_
bereinstimmen
If Not ((Sheets("Berichtsdaten").Cells(lv - 1, 17).Value = Spezifikation) And _
(Sheets("Berichtsdaten").Cells(lv - 1, 11).Value = Fehlerart) And _
(Sheets("Berichtsdaten").Cells(lv - 1, 12).Value = Verursacher)) Then
zeile = zeile + 1
If zeile > kopieren_ab Then
Sheets(berichtsname).Rows(zeile - 1).Copy _
Destination:=Sheets(berichtsname).Rows(zeile)
Sheets(berichtsname).Rows(zeile).ClearContents
End If
Else
tmp = 1
End If
End If
Sheets(berichtsname).Cells(zeile, 8).Value = Fehlerart
'Anzahl der Fehler rechts daneben kopieren um später die relative Häufigkeit zu  _
berechnen
If IsEmpty(Sheets(berichtsname).Cells(zeile, 12).Value) Then
Sheets(berichtsname).Cells(zeile, 12).Value = 1
Else
Sheets(berichtsname).Cells(zeile, 12).Value = Sheets(berichtsname).Cells(zeile, 12). _
_
Value + 1
End If
'evt. Bemerkungen & Maßnahmen reintexten
If Bemerkung <> "" Then Bemerkung = vbLf & "- " & Bemerkung
If Maßnahme <> "" Then Maßnahme = "- " & Maßnahme & vbLf
If tmp = 1 Then
Sheets(berichtsname).Cells(zeile, 6).Value = Sheets(berichtsname).Cells(zeile, 6).Value  _
_
& Bemerkung
Sheets(berichtsname).Cells(zeile, 9).Value = Sheets(berichtsname).Cells(zeile, 9).Value  _
_
& Maßnahme
Else
Sheets(berichtsname).Cells(zeile, 6).Value = Spezifikation & Bemerkung
Sheets(berichtsname).Cells(zeile, 9).Value = Maßnahme
End If
tmp = 0
Next
merken = zeile
'Nach rechts kopieren um sortieren zu können - geht mit verbundenen Zellen NICHT
For satz = 5 To merken
Sheets(berichtsname).Cells(satz, 13).Value = Sheets(berichtsname).Cells(satz, 6).Value
Sheets(berichtsname).Cells(satz, 14).Value = Sheets(berichtsname).Cells(satz, 8).Value
Sheets(berichtsname).Cells(satz, 17).Value = Sheets(berichtsname).Cells(satz, 9).Value
Sheets(berichtsname).Cells(satz, 15).Value = Sheets(berichtsname).Cells(satz, 12).Value
'Sortierhilfe erstellen, damit später LB,A,B kommt (ist weder Auf- noch Absteigend...)
Select Case Sheets(berichtsname).Cells(satz, 14).Value
Case Is = "LB": Sheets(berichtsname).Cells(satz, 16).Value = 1
Case Is = "A": Sheets(berichtsname).Cells(satz, 16).Value = 2
Case Is = "B": Sheets(berichtsname).Cells(satz, 16).Value = 3
Case Is = "C": Sheets(berichtsname).Cells(satz, 16).Value = 4
Case Else: Sheets(berichtsname).Cells(satz, 16).Value = 5
End Select
Next
'Jetzt sortieren nach Häufigkeit der Fehler
Sheets(berichtsname).Visible = True
Sheets(berichtsname).Activate
Sheets(berichtsname).Range(Cells(5, 12), Cells(merken, 17)).Select
Selection.sort _
Key1:=Sheets(berichtsname).Range("P1"), Order1:=xlAscending, _
Key2:=Sheets(berichtsname).Range("L1"), Order2:=xlDescending, _
Key3:=Sheets(berichtsname).Range("M1"), Order3:=xlDescending
'Wieder von rechts nach links zurückkopieren & laufende nummer eintragen
Sheets(berichtsname).Cells(5, 5) = 1
For satz = 5 To merken
Sheets(berichtsname).Rows(satz).RowHeight = 108.75
Cells(satz, 6).Value = Cells(satz, 13).Value
Cells(satz, 9).Value = Cells(satz, 17).Value
'Rel. Hfgk berechnen
If Range("DWB_" + cbxModell + "!C5").Value <> 0 Then
Sheets(berichtsname).Cells(satz, 7).Value = Sheets(berichtsname).Cells(satz, 12). _
Value / Range("DWB_" + cbxModell + "!C5").Value
Else
Sheets(berichtsname).Cells(satz, 7).Value = 0
End If
Sheets(berichtsname).Cells(satz, 8).Value = Sheets(berichtsname).Cells(satz, 14).Value
'Sheets(berichtsname).Rows(satz).AutoFit
'laufende nummer addieren, da es probleme gab wenn mehrmal der selbe fehler auftrat
If satz > 5 Then _
Sheets(berichtsname).Cells(satz, 5).Value = _
Sheets(berichtsname).Cells(satz - 1, 12).Value + Sheets(berichtsname).Cells(satz -   _
_
1, 5).Value
Next satz
'Temporäre Tabelle wieder leeren
Sheets(berichtsname).Range(Cells(5, 12), Cells(merken, 17)).ClearContents
Else
'Festlegen des Seitenbereichs auch falls keine Berichtsdaten vorliegen
kopieren_ab = 14
merken = 1
End If
'Export in Datei
Call ExportWochenBericht(ExportName, cbxModell, CInt(kopieren_ab), CInt(merken))
'Ausblenden der entsprechenden Tabellenblätter
Worksheets("WB_" + cbxModell).Visible = xlVeryHidden
Worksheets("DWB_" + cbxModell).Visible = xlVeryHidden
Worksheets("FWB_" + cbxModell).Visible = xlVeryHidden
'Festlegung für nächsten Durchlauf
näxtmodell:
If durchlauf = 1 Then cbxModell = "B6"
If durchlauf = 2 Then cbxModell = "A6"
Next durchlauf
If durchlauf = 1 Then cbxModell = "B6"
If durchlauf = 2 Then cbxModell = "A6"
'Ausblenden der entsprechenden Tabellenblätter
Worksheets("Berichtsdaten").Visible = xlVeryHidden
Worksheets("tmp").Visible = xlVeryHidden
Worksheets("Daten").Visible = xlVeryHidden
Worksheets("Menü").Activate
'Abspeichern der Datei
ActiveWorkbook.Save
Application.ScreenUpdating = True
Exit Sub
Err_Handler:
Application.ScreenUpdating = True
Call MsgBox("!FEHLER!", vbCritical, "SHIT")
End Sub

Hallo René,
deaktiviere während der Makroausführung das autoatische Berechnen
zu Beginn
Application.Calculation = xlCalculationManual
innerhalb des Codes fügst du an allen Positionen wo die Tabellen vor Folgeaktionen aktualisiert werden müssen ein:
Application.Calculate
am Ende ggf. wieder einschalten
Application.Calculation = xlCalculationAutomatic
Gruß
Franz

Hallo René,
für einen Beginner ganz guter Code!
Das Wichtigste: Vermeide Activate u. Select (1x Activate am Schluss ist o.K.)
If Sheets("FWB_" + cbxModell).Cells(satz, 12).Value = "" Then
Sheets("FWB_" + cbxModell).Select
Rows(satz - 1).Copy
Rows(satz).Select
Cells(satz, 1).Select
ActiveSheet.Paste
For xx = 1 To 9: Sheets("FWB_" + cbxModell).Cells(satz, xx).ClearContents: Next
End If
If Sheets("FWB_" + cbxModell).Cells(satz, 12).Value = "" Then
Sheets("FWB_" + cbxModell). Rows(satz - 1).Copy Destination:=Cells(satz, 1)
For xx = 1 To 9: Sheets("FWB_" + cbxModell).Cells(satz, xx).ClearContents: Next
End If
Vermeide Schleifen, wenn Du zusammenhängende Zellenblöcke hast:
For xx = 1 To 9: Sheets("FWB_" + cbxModell).Cells(satz, xx).ClearContents: Next
Sheets("FWB_" + cbxModell).Range(Sheets("FWB_" + cbxModell).Cells(satz, 1),Sheets("FWB_" + cbxModell).Cells(satz, 9)).ClearContents
Wenn Du damit durch bist u. dein Code eine Laufzeit von unter zwei Minuten hat,
kannst dich ja nochmal melden.
Gruß Gerd

Und pompt etwas vergessen:
Sheets("FWB_" + cbxModell). Rows(satz - 1).Copy Destination:=Sheets("FWB_" + cbxModell).Cells(satz, 1)
Gerd

HI
das ist jetzt natürlich etwas umfangreich, aber so ein paar unnötige Zinken sind schon drin:

For xx = 1 To 9: Sheets("FWB_" + cbxModell).Cells(satz, xx).ClearContents: Next

Die Schleife brauchts nicht,
das reicht und sollte schneller sein:

Sheets("FWB " & cbxModell).Cells(satz, 1).Resize(,9).ClearContents

ebenso das hier:

'tabellenlänge feststellen
lngtab = 1
Do Until Sheets("daten").Cells(lngtab, 1).Value = "": lngtab = lngtab + 1: Loop

geht einfacher:

lngtab = Sheets("daten").Cells(1,1).end(xldown).row + 1

du musst halt mal schauen, ob so Sachen öfters vorkommen.
Schleifen über Zellbereiche sind langsam und oft nicht notwendig.
Gruß, Daniel

Hmmm!
lngtab = Sheets("daten").Cells(1,1).end(xldown).row + 1
"Bei 1000 Zeilen langsamer...."
werden vermutlich die ersten beiden Zellen gefüllt sein, o.K.
Prinzipiell ist aber eine Absicherung von End(xldown) in der Praxis eher notwendig als bei End(xlUp)
Gruß Gerd

Hallo,
ich merke schon das in meinem Code einiges nicht so ganz tacco ist. Amliebsten wäre es mir ja wenn es jemand von Euch so umschreibt das es schneller funzt. Was würde denn so etwas kosten?
Freundliche Grüße René

Hallo René!
.... wäre, Du versuchst, unsere Anregungen selbst unter Zuhilfenahme der VBA-Hilfe
(im Code-Fenster Begriffe die dir unbekannt sind markieren u. F1-Taste drücken) umzusetzen.
Was im Detail alles sinnvoll wäre, kann mann ohne deine Datei u. einer Beschreibung deines
Vorhabens nicht vollständig beurteilen. Du solltest dieses Forum als Hilfe zur Selbsthilfe verstehen.
Ansonsten kannst Du z.B. oben auf Auftragsprogrammierung u. dort weiter klicken.
Gruß Gerd

Okay Gerd,
werde es erst selbst versuchen und wenn ich alles durcheinanderbringen sollte kann ich immer noch einen Auftrag erteilen. Aber das ist doch bestimmt ganz schön teuer?
Danke erst mal für dei wertvollen Hinweise, habe mich sehr gefreut Ist immer wieder interssant hier und hilft sehr.
Grüße von René