Excelabsturz

Sub Kontennachweis()
Dim Jahr As Integer
Start = Timer
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'  Jahr = InputBox("Welches Jahr möchten Sie abgleichen?", "Frage", Year(Date))
Trennzeichen = Application.PathSeparator 'betriebssystemspezifisches Trennzeichen  _
Inputdatenpfad
Mandant = ThisWorkbook.Worksheets("Master").Range("D5").Offset(0, 0).Value
Berater = ThisWorkbook.Worksheets("Master").Range("D6").Offset(0, 0).Value
Modulpfad = "D:\Kundenmanagement\Einzelkunden\" & Berater & "-" & Mandant &  _
Trennzeichen
Modul = "Modul_" & Mandant & ".xlsb"
Jahr = Year(GetValue(Modulpfad, Modul, "Cockpit", "C4"))
Jahresordner = Jahr & ThisWorkbook.Sheets("Blatt2").Range("O18").Value
Pfad_Input = "D:\Dateninput\" & Berater & Trennzeichen & Mandant & Trennzeichen &  _
Jahresordner & Trennzeichen
Konten = "Kontennachweis.csv"
Ident = ThisWorkbook.Sheets("Blatt2").Range("L26").Value 'Kontengruppe Kasse für  _
Identifikation Anzahl Kontenstellen
On Error Resume Next
If Workbooks(Konten) Is Nothing Then Workbooks.Open Filename:=Pfad_Input & Konten, local:= _
True
On Error GoTo 0
'  Workbooks(Konten).Activate
'Spalte A aufsteigend sortieren (zuerst 1 -> Handelsbilanz)
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range("A1:A284"), SortOn:=xlSortOnValues, Order:= _
xlAscending
With ActiveSheet.Sort
.SetRange Range("A1:P284")
.Apply
End With
'Einträge Steuerbilanz (Zeilen mit Merkmal 2) löschen
Startzelle = "A1"
For i = 0 To 1000
If Range(Startzelle).Offset(i, 0) = "" Then Exit For
If Range(Startzelle).Offset(i, 0).Value = 2 Then Range(Startzelle).Offset(i, 0).EntireRow. _
Delete: i = i - 1
Next i
'  Workbooks(Konten).Activate
'Konten aufsteigend sortieren (um Dupletten zu entfernen)
Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1:P1").AutoFilter
ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range("L1:L1000"), SortOn:=xlSortOnValues,  _
Order:=xlAscending
ActiveSheet.AutoFilter.Sort.Apply
'Dupletten entfernen
Startzelle = "L1"
For i = 1 To 1500
If Range(Startzelle).Offset(i + 1, -3) = "" Then Exit For
If Range(Startzelle).Offset(i + 1, 0).Value = "" Then Range(Startzelle).Offset(i + 1, 2). _
Value = Range(Startzelle).Offset(i + 1, -2).Value
If Range(Startzelle).Offset(i + 1, 0).Value = Range(Startzelle).Offset(i, 0).Value And  _
Range(Startzelle).Offset(i, 0).Value  "" Then Range(Startzelle).Offset(i + 1, 0).EntireRow. _
Delete: i = i - 1
Next i
'Nutzlose Spalten löschen
Range("A:C,E:H,J:K").Delete Shift:=xlToLeft
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=  _
xlAscending
ActiveSheet.AutoFilter.Sort.Apply
'Anzahl Stellen im selektiertem Jahr -> Multiplikator
'  ActiveSheet.Columns("B:B").Find(What:=Ident).Activate: Stellen_Ist = Len(ActiveCell.Offset(0, _
1).Value)
'  Stellen_Soll = GetValue(Modulpfad, Modul, "Annahmen", "F16")
'  Multiplikator = 10 ^ (Stellen_Soll - Stellen_Ist)
ActiveSheet.Columns("B:B").Find(What:=Ident).Activate: Stellen_Ist = Len(ActiveCell.Offset(0, _
1).Value)
Workbooks.Open Filename:=Modulpfad & Modul
Stellen_Soll = Workbooks(Modul).Worksheets("Annahmen").Range("F16").Value
Multiplikator = 10 ^ (Stellen_Soll - Stellen_Ist)
Workbooks(Konten).Activate
'Formatierung
ActiveWindow.DisplayGridlines = False
Columns("C:E").Cut: Range("A1").Insert Shift:=xlToRight
Columns("D:E").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("G:G").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("A:H").EntireColumn.AutoFit
Cells.Replace What:="AKTIVA", Replacement:="Aktiva", MatchCase:=True
Cells.Replace What:="PASSIVA", Replacement:="Passiva", MatchCase:=True
'Berechnungsformeln
Range("D2:D" & i + 1 & "").FormulaR1C1 = "=IF(RC1="""","""",SUMPRODUCT(('" & Modulpfad & "[" & _
Modul & "]Ist-Daten'!R11C3:R10000C3=RC1*" & Multiplikator & ")" & _
"*('" & Modulpfad & "[" & Modul & "]Ist-Daten'!R11C3:R11C13=" & Jahr & "),'" & Modulpfad & " _
[" & Modul & "]Ist-Daten'!R11C3:R10000C13))"
Range("G2:G" & i + 1 & "").FormulaR1C1 = "=IFERROR(VLOOKUP(RC1*" & Multiplikator & ",'" &  _
Modulpfad & "[" & Modul & "]Ist-Daten'!R12C3:R10000C7,5,FALSE),"""")"
Range("I2:I" & i + 1 & "").FormulaR1C1 = "=VLOOKUP(RC1*" & Multiplikator & ",'" & Modulpfad &  _
"[" & Modul & "]Ist-Daten'!R12C3:R10000C7,3,FALSE)"
Rows("2:7").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
For j = 1 To 4
If j = 1 Then begriff = "Summe Aktiva"
If j = 2 Then begriff = "Summe Passiva"
If j = 3 Then begriff = "Jahresüberschuss": Begriff_1 = "Jahresfehlbetrag"
If j = 4 Then begriff = "Bilanzgewinn": Begriff_1 = "Bilanzverlust"
On Error Resume Next
Zeile = Cells.Find(What:=begriff, After:=ActiveCell, LookAt:=xlWhole, MatchCase:=True).Row
If Zeile = "" Then Zeile = Cells.Find(What:=Begriff_1, LookAt:=xlWhole, MatchCase:=True).Row
Range("A" & Zeile & ":I" & Zeile & "").Cut: Range("A" & j + 1 & "").Select: ActiveSheet.Paste: _
Rows("" & Zeile & ":" & Zeile & "").Delete Shift:=xlUp 'Bilanzsumme Aktiva
On Error GoTo 0
Zeile = ""
Next j
'  Range("D2").Value = GetValue(Modulpfad, Modul, "Ist_Daten", "M7")
'  Range("D3").Value = GetValue(Modulpfad, Modul, "Ist_Daten", "M8")
'  Range("D4").Value = GetValue(Modulpfad, Modul, "Ist_Daten", "M9")
Range("D2").Value = Workbooks(Modul).Worksheets("Ist-Daten").Range("M7").Value
Range("D3").Value = Workbooks(Modul).Worksheets("Ist-Daten").Range("M8").Value
Range("D4").Value = Workbooks(Modul).Worksheets("Ist-Daten").Range("M6").Value
Range("A1:I7").Font.Bold = True
Range("H2:H5").Copy: Range("B2").PasteSpecial Paste:=xlPasteValues: Application.CutCopyMode =  _
False
Range("F2:I5, H1:I500").ClearContents
Columns("A:G").EntireColumn.AutoFit
Range("C1, C7, F7").Value = "Original": Range("D1, D7, G7").Value = "Modul"
'      ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources, Type:=xlExcelLinks
DoEvents
Calculate
DoEvents
Range("E2:E4, E8:E" & i + 1 & "").FormulaR1C1 = "=IF(OR(ROUND(ABS(RC[-2]),2)ROUND(ABS(RC[-1] _
),2),AND(ROUND(RC[-2]*-1,2)=ROUND(RC[-1],2),RC[1]=RC[2])),RC[-2]-RC[-1],"""")"
'  Range("D2:I" & i + 1 & "").Copy: Range("D2").PasteSpecial Paste:=xlPasteValues: Application. _
CutCopyMode = False
Range("C2:E" & i + 1 & "").NumberFormat = "#,##0_ ;[Red]-#,##0 "
Columns("A:I").EntireColumn.AutoFit
'Bedingte Formatierung
Cells.FormatConditions.Delete
Range("A8:G100").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=UND($F8$G8;$F8"""")"
With Selection.FormatConditions(1).Interior
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.799981688894314
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("A8:G100").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$E8"""""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.799981688894314
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("B2:E4").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$E4"""""
With Selection.FormatConditions(1).Interior
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.799981688894314
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.AutoFilter
ActiveWorkbook.SaveAs Filename:=Pfad_Input & "Kontennachweis_bearbeitet.xlsx", FileFormat:= _
xlOpenXMLWorkbook
Workbooks(Modul).Close 'Kritischer Punkt!
Range("A1").Select
Application.ScreenUpdating = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Debug.Print "Gesamt: " & Timer - Start
End Sub