VBA ausführen wenn Reitername XX enthält

Sub Kopieren()
Dim Worksheet, Pfad
Dim wb As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Pfad = Worksheets("YY").Range("A1")
For Each Worksheet In Worksheets
If Left(Worksheet.name, 4) = "XXX_" Then
Set wb = Workbooks.Add
Worksheet.Copy After:=wb.Sheets(wb.Sheets.Count)
wb.Worksheets(1).Delete
wb.SaveAs Filename:=Pfad & "\" & Worksheet.name
wb.Close saveChanges:=True
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Sub Formatieren()
Dim Zelle As Range, Zaehler As Integer, Wert As Integer
Wert = CInt(Sheets("YY).Range("D4")) 'Anpassen
With ActiveSheet
.Unprotect  'Blattschutz aufheben
.Cells.Locked = True  'alle Zellen im Blatt sperren
For Each Zelle In .Range("F5:Q5")
Zaehler = Zaehler + 1
'Zellen nach Prüfung sperren
If Zaehler 

Sub Kopieren()
Dim Worksheet, Pfad
Dim wb As Workbook
Dim Zelle As Range, Zaehler As Integer, Wert As Integer
Wert = CInt(Sheets("YY).Range("D4")) 'Anpassen
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Pfad = Worksheets("YY").Range("A1")
For Each Worksheet In Worksheets
If Left(Worksheet.name, 4) = "XXX_" Then
With ActiveSheet
.Unprotect  'Blattschutz aufheben
.Cells.Locked = True  'alle Zellen im Blatt sperren
For Each Zelle In .Range("F5:Q5")
Zaehler = Zaehler + 1
'Zellen nach Prüfung sperren
If Zaehler