Alle Sheet mitkopieren VBA
02.10.2020 13:00:34
Mike
mir wurde bereits durch Franz viel geholfen. Leider klappt der Macro aber noch nicht ganz. Im Moment wird nur das Sheet Infrastructure mit kopiert. Es sollen aber alle Sheets mit kopiert werden und die Verbindungen dabei erhalten bleiben. Eigentlich soll jedes neu abgespeicherte Dokument die Sheets der Ursprungsdatei beinhalten nur eben die Werte sollen ausgetauscht werde.
Kann mir hier jemand bitte helfen, ich bin echt am verzweifeln...:(
LG
MIKE
Anbei noch die Datei: https://www.herber.de/bbs/user/140590.xlsm
Der Code:
Sub Test()
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\xxx\Desktop\Bottomup Templates\" & strDatum & _
"_Market Estimations_RegX_"
Set Qw = ThisWorkbook.Worksheets("Input data")
Set Zw = ThisWorkbook.Worksheets("Infrastructure", "Superstructure")
For Each Z In Qw.Range("A2", Qw.Range("A1").End(xlDown)).Cells
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
Zw.Copy
Set Nw = ActiveWorkbook
Nw.SaveAs _
Filename:=strOrdnerZiel & Z.Offset(0, 1).Value & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False