Makro zu langsam

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 = Anfang) And (aktdatum = 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  "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