Readdy Write  
0,00 €
Your View Money
Views: Count
Self 20% 0
Your Content 60% 0

Users by Links 0
u1*(Content+Views) 10% 0
Follow-Follower 0
s2*(Income) 5% 0

Count
Followers 0
Login Register as User

Gelöst: Excel vba crash : ApplyTheme und Delete

06.03.2019 (­čĹü1616)

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