Gelöst: Excel vba crash
Problem gelöst:
Wenn man in Excel vba versucht ein Farb-Schema / Design-Schema auf eine neue Excel Arbeitsmappe zu übertragen, dann kann es sein, dass Excel abstürzt
Fehlermeldung:
Microsoft Excel funktioniert nicht mehr Windows kann versuchen, die Informationen wiederherzustellen und das Programm neu zu starten. è Programm neu starten |
Die Ursache liegt im vba Makro Code:
'< delete_sheet1 > workbook_Export.Sheets(2).Delete '</ delete_sheet1 > workbook_Export.ApplyTheme wb.FullName |
Lösung:
Man darf nicht nach einer .delete Anweisung anschliessend ein Applytheme ausführen.
In der anderen Reihenfolge kommt kein Fehler
Referenz Code:
Kopieren von Excel-Blättern in eine neue Ausgabe-Datei
Screenshot: Absturz durch fehlerhaften Code
Option Explicit Public Const °Eingabeordner = "02_Eingabe" '***********< Schutz und Eingabe >**************** '*Eingabefelder anpassen '* Public Sub Eingabeblaetter_exportieren() '-----------------< Eingabeblaetter_exportieren() >----------------- '< active Workbook > Dim wb As Workbook Set wb = ActiveWorkbook '</ active Workbook >
'< check_Eingabeordner > Dim fs As FileSystemObject Set fs = New FileSystemObject If fs.FolderExists(ThisWorkbook.Path & "\" & °Eingabeordner) = False Then fs.CreateFolder ThisWorkbook.Path & "\" & °Eingabeordner End If Set fs = Nothing '</ check_Eingabeordner >
'----< Sheets ermitteln >---- On Error Resume Next '--< @Loop: alle Sheets >-- '----< ID_ermitteln >---- Dim Liste_Bereiche As ListObject Set Liste_Bereiche = wb.Sheets("Steuerung").ListObjects("Liste_Bereiche") '----</ ID_ermitteln >---- Dim row As ListRow For Each row In Liste_Bereiche.ListRows Dim sWert As String sWert = Liste_Bereiche.ListColumns("Aktiv").DataBodyRange(row.Index) sWert = LCase(sWert) If sWert = "x" Then '--< erstellen >-- '< Bereich_ermitteln > Dim sBereich As String sBereich = Liste_Bereiche.ListColumns("Bereich").DataBodyRange(row.Index)
Dim ws As Worksheet Set ws = wb.Worksheets(sBereich) '</ Bereich_ermitteln > If Err.Number <> 0 Then MsgBox Err.Description, vbCritical, "Abbruch" Exit Sub End If
Application.StatusBar = Now & " Eingabefelder anpassen " & sBereich Eingabeblatt_exportieren wb, ws '--</ erstellen >-- End If Next '--< @Loop: alle Sheets >--
Application.StatusBar = Now & " fertig: Export-Dateien erstellt" '-----------------</ Eingabeblaetter_exportieren() >----------------- End Sub
Public Sub Eingabeblatt_exportieren(ByVal wb As Workbook, ByVal ws As Worksheet) '-----------------< Eingabefelder_anpassen_in_Blatt() >----------------- '*erstellt ein Blatt als Eingabeblatt in einer neuen Datei Dim sSheetname As String sSheetname = ws.Name '----< Sheets ermitteln >---- Application.StatusBar = Now & " copy sheet " & ws.Name DoEvents Application.ScreenUpdating = False
Dim workbook_Export As Workbook Set workbook_Export = Workbooks.Add()
ws.Copy Before:=workbook_Export.Sheets(1) Set ws = workbook_Export.Sheets(ws.Name) ws.Activate
'< Design-Farb-Schema uebernehmen > 'DoEvents '#crash verhindern workbook_Export.ApplyTheme wb.FullName '</ Design-Farb-Schema uebernehmen >
'##--< Export_Anpassen >--## Zeilen_Spalten_auf_Blatt_einausblenden ws, SetAnsicht:=False Eingabefelder_anpassen_in_Blatt ws, SetAnsicht:=True Schutz_Eingabe_in_Blatt_einschalten ws '##--</ Export_Anpassen >--##
'< NormalView > workbook_Export.Activate ActiveWindow.View = xlNormalView '*Ansicht auf PrintPreview xlPageBreakPreview xlLandscape '</ NormalView >
'< delete_sheet1 > Application.DisplayAlerts = False '*suppress alert: delete sheet1 und save.overwrite workbook_Export.Sheets(2).Delete '</ delete_sheet1 >
'< save > Application.StatusBar = Now & "speichern Datei: " & ws.Name workbook_Export.SaveAs wb.Path & "\" & °Eingabeordner & "\" & ws.Name '</ save >
workbook_Export.Close Set workbook_Export = Nothing Application.DisplayAlerts = True DoEvents
Application.StatusBar = Now & " fertig: Blatt exportiert " & sSheetname '-----------------</ Eingabefelder_anpassen_in_Blatt() >----------------- End Sub |
Vba makro code, microsoft excel