Systemfehler &h80010108 - Excel hängt sich auf

Option Explicit
Public Sub btnBerichtErstellen_anklicken()
Dim strFQDN As String
Dim strDateiname As String
Dim strFilterRS As String
Dim strFilterRB As String
Dim strFilterOE As String
Dim strFilterG1 As String
Dim intBericht As Integer
Dim rngAuswahl As Range
Dim i As Integer
'    On Error GoTo ErrHandler
'Pr¸fen ob andere Arbeitsmappen geoeffnet sind
If Application.Workbooks.Count > 1 Then
MsgBox ("Es sind andere Arbeitsmappen geˆffnet!" _
& vbCrLf & "Beenden Sie alle anderen Arbeitsmappen" _
& vbCrLf & "bevor Sie mit der Berichtserstellung beginnen!.")
Exit Sub
End If
'Pr¸fen ob Verzeichnisse vorhanden sind
If funcVerzeichnissePruefen = False Then
MsgBox ("Es existiert mindestens ein Verzeichnis unter dem angegebenen Pfad nicht!" _
& vbCrLf & "Bitte ¸berpr¸fen Sie das Protokoll.")
Exit Sub
End If
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 4 To 104
On Error GoTo Err
If Not IsEmpty(Tabelle0.Cells(2, i).Value) Then
If Not IsEmpty(Tabelle0.Cells(4, i).Value) And Not IsEmpty(Tabelle0.Cells(5, i). _
Value) Then
strFQDN = Tabelle0.Cells(3, 4).Value & Tabelle0.Cells(4, i).Value & "\" _
& Tabelle0.Cells(5, i).Value & ".xlsb"
strDateiname = Tabelle0.Cells(5, i).Value & ".xlsb"
strFilterRS = Tabelle0.Cells(6, i).Value
strFilterRB = Tabelle0.Cells(7, i).Value
strFilterOE = Tabelle0.Cells(8, i).Value
strFilterG1 = Tabelle0.Cells(9, i).Value
intBericht = Tabelle0.Cells(1, i).Value
Application.ScreenUpdating = True
Application.StatusBar = "Bericht " & Tabelle0.Cells(5, i).Value & " wird gerade  _
erstellt."
DoEvents
Application.ScreenUpdating = False
Call prcBerichtErstellen(strFilterRS, strFilterRB, strFilterOE, strFilterG1,  _
strFQDN, _
strDateiname, intBericht)
Else
MsgBox ("Kein Verzeichnis- oder Dateinamen angegeben. Bericht wird nicht  _
erstellt.")
End If
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.CutCopyMode = False
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox ("Programmausf¸hrung beendet.")
Exit Sub
Err:
ThisWorkbook.Worksheets("Protokoll").Cells(i - 2, 5).Value = "!FEHLER! " & Err.Description
Application.Calculation = xlCalculationAutomatic
Application.CutCopyMode = False
Resume Next
End Sub
Private Sub prcBerichtErstellen(strFilterRS As String, _
strFilterRB As String, _
strFilterOE As String, _
strFilterG1 As String, _
strFQDN As String, _
strDateiname As String, _
intBericht As Integer)
Dim rngFilterRange As Range
Dim lngKriterienAnzahl As Long
Dim arrKriterien() As String
Dim arrRS() As String
Dim arrRB() As String
Dim arrOE() As String
Dim arrG1() As String
Dim aLinks As Variant
Dim Ding
Dim i As Integer
Dim wkbBericht As Workbook
Dim rngDatensaetze As Range
Dim rngZeilen As Range
'Bei Fehler zur Fehlerbehandlung
On Error GoTo ErrHandler
'Bildschirmaktualisierung deaktivieren
Application.ScreenUpdating = False
'Ereignisse ausschalten
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
'Template ˆffnen
Application.Workbooks.Open (ThisWorkbook.Path & "\Vorlage_Steuerungsbericht_2.xlsb")
DoEvents
'Template aktivieren
Set wkbBericht = Application.Workbooks("Vorlage_Steuerungsbericht_2.xlsb")
'Wenn ein Autofilter auf der Basistabelle aktiv ist, dann ausschalten und neu einschalten,  _
sonst einschalten
If ThisWorkbook.Worksheets("Basistabelle D").AutoFilterMode Then
ThisWorkbook.Worksheets("Basistabelle D").AutoFilterMode = False
ThisWorkbook.Worksheets("Basistabelle D").Rows("2:2").AutoFilter
Else
ThisWorkbook.Worksheets("Basistabelle D").Rows("2:2").AutoFilter
End If
Set rngDatensaetze = ThisWorkbook.Worksheets("Basistabelle D").Range("$A$2:$BQ$" _
& ThisWorkbook.Worksheets("Basistabelle D").UsedRange.Rows.Count)
'Wenn Filter Region nicht "", dann Autofilter Spalte 5 auf betreffende Region setzen
If Not strFilterRS = "" Then
arrRS = Split(strFilterRS, ";")
rngDatensaetze.AutoFilter Field:=5, Criteria1:=strFilterRS, Operator:=xlFilterValues
End If
'Wenn Filter Ressort nicht "", dann Autofilter Spalte 2 auf betreffendes Ressort setzen;  _
Ausnahme Werke
If Not strFilterRB = "" Then
arrRB = Split(strFilterRB, ";")
rngDatensaetze.AutoFilter Field:=2, Criteria1:=strFilterRB, Operator:=xlFilterValues
End If
'Wenn Filter OE nicht "", dann Autofilter Spalte 6 auf betreffende OE setzen
If Not strFilterOE = "" Then
arrOE = Split(strFilterOE, ";")
rngDatensaetze.AutoFilter Field:=6, Criteria1:=strFilterOE, Operator:=xlFilterValues
End If
'Wenn Filter Gruppe1 nicht "", dann Autofilter Spalte 4 auf betreffende Gruppe1 setzen
If Not strFilterG1 = "" Then
arrG1 = Split(strFilterG1, ";")
rngDatensaetze.AutoFilter Field:=4, Criteria1:=arrG1(), Operator:=xlFilterValues
End If
'gefilterte Basisdaten kopieren
rngDatensaetze.SpecialCells(xlCellTypeVisible).Copy
'warten
DoEvents
'Basisdaten einf¸gen
wkbBericht.Worksheets("Basisdaten").Range("A1").PasteSpecial Paste:= _
xlPasteValuesAndNumberFormats
'warten
DoEvents
'Zwischenspeicher lˆschen
Application.CutCopyMode = False
'Speicher freigeben
Set rngDatensaetze = Nothing
'Autofilter ausschalten
ThisWorkbook.Worksheets("Basistabelle D").AutoFilterMode = False
'Uebersichten rueckwaerts kopieren gem. Konfiguration
For i = 28 To 10 Step -1
If ThisWorkbook.Worksheets("Konfiguration").Cells(i, intBericht + 3).Value = "" Then
wkbBericht.Worksheets(ThisWorkbook.Worksheets("Konfiguration").Cells(i, 2).Value). _
Delete
End If
Next i
DoEvents
If ThisWorkbook.Worksheets("Konfiguration").Cells(43, intBericht + 3).Value  "" Then
'Pivottabelle auf neue Datenquelle verkn¸pfen und aktualisieren
With wkbBericht
.Worksheets("PD Pivot").EnableCalculation = True
'            .Worksheets("PD Pivot").PivotTables("Basisdaten").ChangePivotCache .PivotCaches. _
Create(SourceType:=xlDatabase, _
SourceData:=wkbBericht.Worksheets("Basisdaten") _
.Range("A1:BQ" & wkbBericht.Worksheets("Basisdaten") _
.Cells(Rows.Count, 1).End(xlUp).Row + 1), Version:= _
xlPivotTableVersion14)
.Worksheets("PD Pivot").PivotTables("PDPivot").SaveData = True
.Worksheets("PD Pivot").PivotTables("PDPivot").PivotCache.RefreshOnFileOpen = False
.Worksheets("PD Pivot").PivotTables("PDPivot").PivotCache.Refresh
.Worksheets("PD Pivot").PivotTables("PDPivot").SaveData = True
'warten
DoEvents
.Worksheets("PD Pivot").EnableCalculation = False
'PD-Pivot Datenblatt verstecken
.Worksheets("PD Pivot").Visible = xlSheetVeryHidden
End With
'Makros verlinken
wkbBericht.Worksheets("Detail PD").Shapes("btnUpPD").OnAction = _
wkbBericht.Name & "!btnUp_anklicken"
If ThisWorkbook.Worksheets("Konfiguration").Cells(36, intBericht + 3).Value  "" Then
wkbBericht.Worksheets("Detail PD").Shapes("btnLeftPD").OnAction = _
wkbBericht.Name & "!btnLeftPD_anklicken"
ElseIf ThisWorkbook.Worksheets("Konfiguration").Cells(36, intBericht + 3).Value = ""  _
Then
wkbBericht.Worksheets("Detail PD").Shapes("btnLeftPD").OnAction = _
wkbBericht.Name & "!btnLeftRB_anklicken"
End If
wkbBericht.Worksheets("Detail PD").Shapes("btnFullPD").OnAction = _
wkbBericht.Name & "!btnFullPD_anklicken"
'Wenn FIT Diagramm ausgewaehlt, dann Diagramm kopieren, sonst FIT Shapes aus Uebersicht  _
loeschen
If ThisWorkbook.Worksheets("Konfiguration").Cells(49, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("PD FIT").Delete
wkbBericht.Worksheets("Detail PD").Shapes("HeadFITPD").Delete
wkbBericht.Worksheets("Detail PD").Shapes("DiaFITPD").Delete
Else
wkbBericht.Worksheets("PD FIT").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackPD_anklicken"
wkbBericht.Worksheets("Detail PD").Shapes("DiaFITPD").OnAction = _
wkbBericht.Name & "!PD_FIT_aufrufen"
wkbBericht.Worksheets("PD FIT").Visible = xlSheetVeryHidden
End If
'Wenn Gesundheitstand Diagramm ausgewaehlt, dann Diagramm kopieren
If ThisWorkbook.Worksheets("Konfiguration").Cells(48, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("PD Gesund").Delete
wkbBericht.Worksheets("Detail PD").Shapes("HeadGesundPD").Delete
wkbBericht.Worksheets("Detail PD").Shapes("DiaGesundPD").Delete
Else
wkbBericht.Worksheets("PD Gesund").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackPD_anklicken"
wkbBericht.Worksheets("Detail PD").Shapes("DiaGesundPD").OnAction = _
wkbBericht.Name & "!PD_Gesund_aufrufen"
wkbBericht.Worksheets("PD Gesund").Visible = xlSheetVeryHidden
End If
'Wenn Urlaubs Diagramm ausgewaehlt, dann Diagramm kopieren
If ThisWorkbook.Worksheets("Konfiguration").Cells(47, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("PD Urlaub").Delete
wkbBericht.Worksheets("Detail PD").Shapes("HeadUrlaubPD").Delete
wkbBericht.Worksheets("Detail PD").Shapes("DiaUrlaubPD").Delete
Else
wkbBericht.Worksheets("PD Urlaub").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackPD_anklicken"
wkbBericht.Worksheets("Detail PD").Shapes("DiaUrlaubPD").OnAction = _
wkbBericht.Name & "!PD_Urlaub_aufrufen"
wkbBericht.Worksheets("PD Urlaub").Visible = xlSheetVeryHidden
End If
'Wenn Minderleistungs Diagramm ausgewaehlt, dann Diagramm kopieren
If ThisWorkbook.Worksheets("Konfiguration").Cells(46, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("PD Minder").Delete
wkbBericht.Worksheets("Detail PD").Shapes("HeadMinderPD").Delete
wkbBericht.Worksheets("Detail PD").Shapes("DiaMinderPD").Delete
Else
wkbBericht.Worksheets("PD Minder").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackPD_anklicken"
wkbBericht.Worksheets("Detail PD").Shapes("DiaMindPD").OnAction = _
wkbBericht.Name & "!PD_Mind_aufrufen"
wkbBericht.Worksheets("PD Minder").Visible = xlSheetVeryHidden
End If
'Wenn Mehrleistungs Diagramm ausgewaehlt, dann Diagramm kopieren
If ThisWorkbook.Worksheets("Konfiguration").Cells(45, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("PD Mehr").Delete
wkbBericht.Worksheets("Detail PD").Shapes("HeadMehrPD").Delete
wkbBericht.Worksheets("Detail PD").Shapes("DiaMehrPD").Delete
Else
wkbBericht.Worksheets("PD Mehr").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackPD_anklicken"
wkbBericht.Worksheets("Detail PD").Shapes("DiaMehrPD").OnAction = _
wkbBericht.Name & "!PD_Mehr_aufrufen"
wkbBericht.Worksheets("PD Mehr").Visible = xlSheetVeryHidden
End If
'Wenn Personal Diagramm ausgewaehlt, dann Diagramm kopieren
If ThisWorkbook.Worksheets("Konfiguration").Cells(44, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("PD Pers").Delete
wkbBericht.Worksheets("Detail PD").Shapes("HeadPersPD").Delete
wkbBericht.Worksheets("Detail PD").Shapes("DiaPersPD").Delete
Else
wkbBericht.Worksheets("PD Pers").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackPD_anklicken"
wkbBericht.Worksheets("Detail PD").Shapes("DiaPersPD").OnAction = _
wkbBericht.Name & "!PD_Pers_aufrufen"
wkbBericht.Worksheets("PD Pers").Visible = xlSheetVeryHidden
End If
End If
DoEvents
If ThisWorkbook.Worksheets("Konfiguration").Cells(36, intBericht + 3).Value  "" Then
'Pivottabelle mit neuer Datenbasis verknuepfen und aktualisieren
With wkbBericht
.Worksheets("RB Pivot").EnableCalculation = True
'            .Worksheets("RB Pivot").PivotTables("RBPivot").ChangePivotCache .PivotCaches. _
Create(SourceType:=xlDatabase, _
SourceData:=wkbBericht.Worksheets("Basisdaten") _
.Range("A1:BQ" & wkbBericht.Worksheets("Basisdaten") _
.Cells(Rows.Count, 1).End(xlUp).Row + 1), Version:= _
xlPivotTableVersion14)
.Worksheets("RB Pivot").PivotTables("RBPivot").SaveData = True
.Worksheets("RB Pivot").PivotTables("RBPivot").PivotCache.RefreshOnFileOpen = False
.Worksheets("RB Pivot").PivotTables("RBPivot").PivotCache.Refresh
.Worksheets("RB Pivot").EnableCalculation = False
'warten
DoEvents
'Tabelle verstecken
.Worksheets("RB Pivot").Visible = xlSheetVeryHidden
End With
'Makros verlinken
wkbBericht.Worksheets("Detail RB").Shapes("btnUpRB").OnAction = _
wkbBericht.Name & "!btnUp_anklicken"
wkbBericht.Worksheets("Detail RB").Shapes("btnLeftRB").OnAction = _
wkbBericht.Name & "!btnLeftRB_anklicken"
If ThisWorkbook.Worksheets("Konfiguration").Cells(43, intBericht + 3).Value  "" Then
wkbBericht.Worksheets("Detail RB").Shapes("btnRightRB").OnAction = _
wkbBericht.Name & "!btnRightRB_anklicken"
End If
'       wkbBericht.Worksheets("Detail RB").Shapes("btnFullRB").OnAction = _
wkbBericht.Name & "!btnFullRB_anklicken"
'Wenn Diagramm FIT ausgewaehlt, dann Diagramm kopieren, sonst FIT-Shapes aus Ubersicht  _
loeschen
If ThisWorkbook.Worksheets("Konfiguration").Cells(42, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("RB FIT").Delete
wkbBericht.Worksheets("Detail RB").Shapes("HeadFITRB").Delete
wkbBericht.Worksheets("Detail RB").Shapes("DiaFITRB").Delete
Else
wkbBericht.Worksheets("RB FIT").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackRB_anklicken"
wkbBericht.Worksheets("Detail RB").Shapes("DiaFITRB").OnAction = _
wkbBericht.Name & "!RB_FIT_aufrufen"
wkbBericht.Worksheets("RB FIT").Visible = xlSheetVeryHidden
End If
'Wenn Diagramm Gesundheit ausgew‰hlt, dann Diagramm kopieren
If ThisWorkbook.Worksheets("Konfiguration").Cells(41, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("RB Gesund").Delete
wkbBericht.Worksheets("Detail RB").Shapes("HeadGesundRB").Delete
wkbBericht.Worksheets("Detail RB").Shapes("DiaGesundRB").Delete
Else
wkbBericht.Worksheets("RB Gesund").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackRB_anklicken"
wkbBericht.Worksheets("Detail RB").Shapes("DiaGesundRB").OnAction = _
wkbBericht.Name & "!RB_Gesund_aufrufen"
wkbBericht.Worksheets("RB Gesund").Visible = xlSheetVeryHidden
End If
'Wenn Diagramm Urlaub ausgew‰hlt, dann Diagramm kopieren
If ThisWorkbook.Worksheets("Konfiguration").Cells(40, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("RB Urlaub").Delete
wkbBericht.Worksheets("Detail RB").Shapes("HeadUrlaubRB").Delete
wkbBericht.Worksheets("Detail RB").Shapes("DiaUrlaubRB").Delete
Else
wkbBericht.Worksheets("RB Urlaub").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackRB_anklicken"
wkbBericht.Worksheets("Detail RB").Shapes("DiaUrlaubRB").OnAction = _
wkbBericht.Name & "!RB_Urlaub_aufrufen"
wkbBericht.Worksheets("RB Urlaub").Visible = xlSheetVeryHidden
End If
'Wenn Diagramm Minderleistung ausgew‰hlt, dann Diagramm kopieren
If ThisWorkbook.Worksheets("Konfiguration").Cells(39, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("RB Minder").Delete
wkbBericht.Worksheets("Detail RB").Shapes("HeadMinderRB").Delete
wkbBericht.Worksheets("Detail RB").Shapes("DiaMinderRB").Delete
Else
wkbBericht.Worksheets("RB Minder").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackRB_anklicken"
wkbBericht.Worksheets("Detail RB").Shapes("DiaMindRB").OnAction = _
wkbBericht.Name & "!RB_Mind_aufrufen"
wkbBericht.Worksheets("RB Minder").Visible = xlSheetVeryHidden
End If
'Wenn Diagramm Mehrleistung ausgew‰hlt, dann Diagramm kopieren
If ThisWorkbook.Worksheets("Konfiguration").Cells(38, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("RB Mehr").Delete
wkbBericht.Worksheets("Detail RB").Shapes("HeadMehrRB").Delete
wkbBericht.Worksheets("Detail RB").Shapes("DiaMehrRB").Delete
Else
wkbBericht.Worksheets("RB Mehr").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackRB_anklicken"
wkbBericht.Worksheets("Detail RB").Shapes("DiaMehrRB").OnAction = _
wkbBericht.Name & "!RB_Mehr_aufrufen"
wkbBericht.Worksheets("RB Mehr").Visible = xlSheetVeryHidden
End If
'Wenn Diagramm Personal ausgew‰hlt, dann Diagramm kopieren
If ThisWorkbook.Worksheets("Konfiguration").Cells(37, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("RB Pers").Delete
wkbBericht.Worksheets("Detail RB").Shapes("HeadPersRB").Delete
wkbBericht.Worksheets("Detail RB").Shapes("DiaPersRB").Delete
Else
wkbBericht.Worksheets("RB Pers").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackRB_anklicken"
wkbBericht.Worksheets("Detail RB").Shapes("DiaPersRB").OnAction = _
wkbBericht.Name & "!RB_Pers_aufrufen"
wkbBericht.Worksheets("RB Pers").Visible = xlSheetVeryHidden
End If
End If
DoEvents
'Wenn Uebersicht Verlauf gewaehlt, dann weiter
If ThisWorkbook.Worksheets("Konfiguration").Cells(29, intBericht + 3).Value  "" Then
'Pivottabelle mit neuer Datenbasis verkn¸pfen und aktualisieren
With wkbBericht
.Worksheets("Verlauf Pivot").EnableCalculation = True
'            .Worksheets("Verlauf Pivot").PivotTables("VerlaufPivot").ChangePivotCache . _
PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:=wkbBericht.Worksheets("Basisdaten") _
.Range("A1:BQ" & wkbBericht.Worksheets("Basisdaten") _
.Cells(Rows.Count, 1).End(xlUp).Row + 1), Version:= _
xlPivotTableVersion14)
.Worksheets("Verlauf Pivot").PivotTables("VerlaufPivot").SaveData = True
.Worksheets("Verlauf Pivot").PivotTables("VerlaufPivot").PivotCache. _
RefreshOnFileOpen = False
.Worksheets("Verlauf Pivot").PivotTables("VerlaufPivot").PivotCache.Refresh
DoEvents
.Worksheets("Verlauf Pivot").EnableCalculation = False
'warten
DoEvents
End With
'Tabelle verstecken
wkbBericht.Worksheets("Verlauf Pivot").Visible = xlSheetVeryHidden
End If
'Makros verlinken
'   wkbBericht.Worksheets("Detail Verlauf").Shapes("btnFullVerlauf").OnAction = _
wkbBericht.Name & "!btnFullVerlauf_anklicken"
wkbBericht.Worksheets("Detail Verlauf").Shapes("btnUpVerlauf").OnAction = _
wkbBericht.Name & "!btnUp_anklicken"
If ThisWorkbook.Worksheets("Konfiguration").Cells(36, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("Detail Verlauf").Shapes("btnRightVerlauf").OnAction = _
wkbBericht.Name & "!btnRightVerlauf_anklicken"
ElseIf ThisWorkbook.Worksheets("Konfiguration").Cells(43, intBericht + 3).Value  "" Then
wkbBericht.Worksheets("Detail Verlauf").Shapes("btnRightVerlauf").OnAction = _
wkbBericht.Name & "!btnRightRB_anklicken"
End If
'Diagramm FIT kopieren; sonst FIT Shapes lˆschen
If ThisWorkbook.Worksheets("Konfiguration").Cells(35, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("Verlauf FIT").Delete
wkbBericht.Worksheets("Detail Verlauf").Shapes("HeadFITVerlauf").Delete
wkbBericht.Worksheets("Detail Verlauf").Shapes("DiaFITVerlauf").Delete
Else
wkbBericht.Worksheets("Verlauf FIT").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackVerlauf_anklicken"
wkbBericht.Worksheets("Detail Verlauf").Shapes("DiaFITVerlauf").OnAction = _
wkbBericht.Name & "!Verlauf_FIT_aufrufen"
wkbBericht.Worksheets("Verlauf FIT").Visible = xlSheetVeryHidden
End If
'Diagramm Gesundheit kopieren
If ThisWorkbook.Worksheets("Konfiguration").Cells(34, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("Verlauf Gesund").Delete
wkbBericht.Worksheets("Detail Verlauf").Shapes("HeadGesundVerlauf").Delete
wkbBericht.Worksheets("Detail Verlauf").Shapes("DiaGesundVerlauf").Delete
Else
wkbBericht.Worksheets("Verlauf Gesund").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackVerlauf_anklicken"
wkbBericht.Worksheets("Detail Verlauf").Shapes("DiaGesundVerlauf").OnAction = _
wkbBericht.Name & "!Verlauf_Gesund_aufrufen"
wkbBericht.Worksheets("Verlauf Gesund").Visible = xlSheetVeryHidden
End If
'Diagramm Urlaub kopieren
If ThisWorkbook.Worksheets("Konfiguration").Cells(33, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("Verlauf Urlaub").Delete
wkbBericht.Worksheets("Detail Verlauf").Shapes("HeadUrlaubVerlauf").Delete
wkbBericht.Worksheets("Detail Verlauf").Shapes("DiaUrlaubVerlauf").Delete
Else
wkbBericht.Worksheets("Verlauf Urlaub").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackVerlauf_anklicken"
wkbBericht.Worksheets("Detail Verlauf").Shapes("DiaUrlaubVerlauf").OnAction = _
wkbBericht.Name & "!Verlauf_Urlaub_aufrufen"
wkbBericht.Worksheets("Verlauf Urlaub").Visible = xlSheetVeryHidden
End If
'Diagramm Minderleistung kopieren
If ThisWorkbook.Worksheets("Konfiguration").Cells(32, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("Verlauf Minder").Delete
wkbBericht.Worksheets("Detail Verlauf").Shapes("HeadMinderVerlauf").Delete
wkbBericht.Worksheets("Detail Verlauf").Shapes("DiaMinderVerlauf").Delete
Else
wkbBericht.Worksheets("Verlauf Minder").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackVerlauf_anklicken"
wkbBericht.Worksheets("Detail Verlauf").Shapes("DiaMindVerlauf").OnAction = _
wkbBericht.Name & "!Verlauf_Mind_aufrufen"
wkbBericht.Worksheets("Verlauf Minder").Visible = xlSheetVeryHidden
End If
'Diagramm Mehrleistung kopieren
If ThisWorkbook.Worksheets("Konfiguration").Cells(31, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("Verlauf Mehr").Delete
wkbBericht.Worksheets("Detail Verlauf").Shapes("HeadMehrVerlauf").Delete
wkbBericht.Worksheets("Detail Verlauf").Shapes("DiaMehrVerlauf").Delete
Else
wkbBericht.Worksheets("Verlauf Mehr").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackVerlauf_anklicken"
wkbBericht.Worksheets("Detail Verlauf").Shapes("DiaMehrVerlauf").OnAction = _
wkbBericht.Name & "!Verlauf_Mehr_aufrufen"
wkbBericht.Worksheets("Verlauf Mehr").Visible = xlSheetVeryHidden
End If
'Diagramm Personal
If ThisWorkbook.Worksheets("Konfiguration").Cells(30, intBericht + 3).Value = "" Then
wkbBericht.Worksheets("Verlauf Pers").Delete
wkbBericht.Worksheets("Detail Verlauf").Shapes("HeadPersVerlauf").Delete
wkbBericht.Worksheets("Detail Verlauf").Shapes("DiaPersVerlauf").Delete
Else
wkbBericht.Worksheets("Verlauf Pers").Shapes("btnBack").OnAction = _
wkbBericht.Name & "!btnBackVerlauf_anklicken"
wkbBericht.Worksheets("Detail Verlauf").Shapes("DiaPersVerlauf").OnAction = _
wkbBericht.Name & "!Verlauf_Pers_aufrufen"
wkbBericht.Worksheets("Verlauf Pers").Visible = xlSheetVeryHidden
End If
'Alle externen Verkn¸pfungen lˆschen
If Not IsEmpty(wkbBericht.LinkSources) Then
aLinks = wkbBericht.LinkSources(xlExcelLinks)
For Each Ding In aLinks
wkbBericht.BreakLink Ding, xlLinkTypeExcelLinks
Next
End If
'Wenn Detail Verlauf Uebersicht kopiert werden soll dann weiter
If ThisWorkbook.Worksheets("Konfiguration").Cells(43, intBericht + 3).Value  "" Then
wkbBericht.Worksheets("PD Pivot").EnableCalculation = True
End If
'Wenn Detail RB Uebersicht kopiert werden soll dann weiter
If ThisWorkbook.Worksheets("Konfiguration").Cells(36, intBericht + 3).Value  "" Then
wkbBericht.Worksheets("RB Pivot").EnableCalculation = True
End If
'Wenn Detail Verlauf Uebersicht kopiert werden soll dann weiter
If ThisWorkbook.Worksheets("Konfiguration").Cells(29, intBericht + 3).Value  "" Then
wkbBericht.Worksheets("Verlauf Pivot").EnableCalculation = True
End If
DoEvents
Application.EnableEvents = True
'Pivottabellen schuetzen
'Wenn Detail Pivot Uebersicht kopiert werden soll dann weiter
If ThisWorkbook.Worksheets("Konfiguration").Cells(43, intBericht + 3).Value  "" Then
wkbBericht.Worksheets("Detail PD").Visible = xlSheetVeryHidden
wkbBericht.Worksheets("PD Pivot").Protect Password:="steuber2015@", UserInterfaceOnly:= _
True, AllowFiltering:=True, AllowUsingPivotTables:=True
End If
'Wenn Detail RB Uebersicht kopiert werden soll dann weiter
If ThisWorkbook.Worksheets("Konfiguration").Cells(36, intBericht + 3).Value  "" Then
wkbBericht.Worksheets("Detail RB").Visible = xlSheetVeryHidden
wkbBericht.Worksheets("RB Pivot").Protect Password:="steuber2015@", UserInterfaceOnly:= _
True, AllowFiltering:=True, AllowUsingPivotTables:=True
End If
'Wenn Detail Verlauf Uebersicht kopiert werden soll dann weiter
If ThisWorkbook.Worksheets("Konfiguration").Cells(29, intBericht + 3).Value  "" Then
wkbBericht.Worksheets("Detail Verlauf").Visible = xlSheetVeryHidden
wkbBericht.Worksheets("Verlauf Pivot").Protect Password:="steuber2015@",  _
UserInterfaceOnly:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
End If
'warten
DoEvents
'Arbeitsmappenberechnung automatisch
Application.Calculation = xlCalculationAutomatic
'warten
DoEvents
'Basisdaten loeschen
wkbBericht.Worksheets("Basisdaten").Visible = xlSheetVeryHidden
'Hochlaufkurven verstecken
wkbBericht.Worksheets("Hochlaufkurven").Visible = xlSheetVeryHidden
'warten
DoEvents
'Ereignisse einschalten
Application.EnableEvents = True
'Arbeitsmappe speichern
wkbBericht.SaveAs Filename:= _
strFQDN, FileFormat:= _
xlExcel12, CreateBackup:=False
'warten bis Vorgang beendet
DoEvents
'Arbeitsmappe schlieflen
wkbBericht.Close
DoEvents
Set wkbBericht = Nothing
'Benachrichtigungen einschalten
Application.DisplayAlerts = True
Exit Sub
ErrHandler:
If Not wkbBericht Is Nothing Then
Set wkbBericht = Nothing
End If
MsgBox "!FEHLER! " & Err.Description  '!!!
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Workbooks("Vorlage_Steuerungsbericht_2.xlsb").Close 'savechanges:=False
DoEvents
End Sub