Option Explicit
Public PM As String
Public Kette As String
Sub PM_Extrakt_erstellen()
Dim monat As String
Dim ws As Worksheet
Dim blname As String
Dim oXlLinks As Variant
Dim i As Integer
Dim aktmonat As String
Workbooks.Add
ActiveWorkbook.SaveAs "Speicherpfad"
Windows("Ursprungsdatei.xlsm").Activate
For Each ws In Worksheets
If Not ws.Tab.Color = 255 Then
If Not ws.Tab.ThemeColor = xlThemeColorAccent2 Then
If ws.Cells(6, 2) = Kette Then
blname = ws.Name
Workbooks("Ursprungsdatei.xlsm").Worksheets("G-" & blname).Copy Before:=Workbooks("XYZ-" & PM & ".xlsx").Sheets(1)
ws.Copy Before:=Workbooks("XYZ-" & PM & ".xlsx").Sheets("G-" & blname)
End If
End If
End If
Next ws
Workbooks("XYZ-" & PM & ".xlsx").Activate
For Each ws In Worksheets
ws.Range("A1").Hyperlinks.Delete
ws.Range("A1").Font.Size = 12
ws.Range("A1").Font.Bold = True
With ws.Range("B6").Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
End With
With ws.Range("I3").Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
End With
With ws.Tab
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
End With
Next ws
Workbooks("XYZ-" & PM & ".xlsx").Worksheets("Tabelle1").Delete
oXlLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
For i = 1 To UBound(oXlLinks)
ActiveWorkbook.BreakLink Name:=oXlLinks(i), _
Type:=xlLinkTypeExcelLinks
Next i
ActiveWorkbook.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub