Mit VBA Arbeitsblätter kopieren

Sub Create_Bottom_Up_Templates()
Dim Qw As Worksheet 'Quelle
Dim Zw As Worksheet 'Ziel
Dim Nw As Workbook 'neue
Dim Z
Dim strOrdnerZiel, strDatum As String
strDatum = InputBox("Datum für zu erstellende Dateien", "Vorlagen erstellen", _
Format(Date, "YYYYMMDD"))
If strDatum = "" Then Exit Sub
strOrdnerZiel = "C:\Users\Nils Blasche\Desktop\Bottomup Templates\New Bottom Up Templates\"  _
_
& strDatum _
& "_Market Estimations_RegX_"
Set Qw = ThisWorkbook.Worksheets("Input data")
For Each Z In Qw.Range("A2", Qw.Range("A1").End(xlDown)).Cells
ThisWorkbook.Sheets(Array("Infrastructure", "Superstructure", "Summary", _
"Manipulation Faktor", "Data_1", "Data_2", "Config")).Copy
Set Nw = ActiveWorkbook
Set Zw = Nw.Worksheets("Infrastructure")
Zw.Range("B3") = Z.Offset(0, 3).Value '[Sales Region], spalte 4
Zw.Range("B4") = Z.Offset(0, 2).Value '[Region], Spalte 3
Zw.Range("B5") = Z.Offset(0, 1).Value '[Country], Spalte 2
Zw.Range("C5") = Z.Value '[Country Code], Spalte 1
Select Case Z.Offset(0, 1).Value
Case "Germany"
Nw.SaveAs _
Filename:=strOrdnerZiel & Z.Offset(0, 1).Value & "_" & Z.Offset(0, 2).Value _
& ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Case Else
Nw.SaveAs _
Filename:=strOrdnerZiel & Z.Offset(0, 1).Value & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Select
Nw.Close savechanges:=False
Next
End Sub