nachdem ich von Uwe sehr schnell eine Antwort zu meinem ersten Anliegen bekommen habe hier nun eine weitere Frage.
Ich will gerne in dem vorhandenen Code noch den Vorgang einbauen, dass mir nicht nur ein Tab nach Ländern aufgeteilt wird sondern noch weitere 4 Tabs aus der Masterdatei die immer gleich sind in die neu erstellten Länder-Dateien kopiert werden. Sprich diese 4 Tabs werden nicht aufgeteilt sondern nur mitkopiert. Der Name der Tabs ist um es zu vereinfachen Tabelle 2, Tabelle 3, Tabelle 4, Tabelle 5 !
Hier der Code:
Sub Aufteilen_Länder()
Dim Land, Arr(), TB1, WB, TBL, Spalte As Integer, Res As Integer
Dim Pfad As String, Datei As String, Ext As String, Finde As String
Dim WF, LC As Integer, rng As Range, Offs As Integer, ErrMeld As String
'****anpassen
'Länder
Arr = Array("DE", "CH", "FR", "IT", "NL", "SE", "GB", "US", "AU", "JP", "SG", "SK", "CN")
Pfad = "C:\Temp\" 'mit \am Ende
Ext = ".xlsx"
Offs = 17 'immer kopieren bis Q
Res = 4 '4 Spalten bei Umsatz
Set TB1 = ThisWorkbook.Sheets("Calculation")
'****Ende anpassen
Set WF = WorksheetFunction
Application.ScreenUpdating = False
With TB1
LC = .Cells(1, .Columns.Count).End(xlToLeft).Column 'letzte Spalte der Zeile 1
Set rng = .Cells(1, Offs + 1).Resize(1, LC - Offs) 'Suchbereich ab R
For Each Land In Arr
'Neue Datei
Set WB = Workbooks.Add
Set TBL = WB.Sheets(1)
'immer kopieren
.Columns(1).Resize(, Offs).Copy TBL.Columns(1)
'Spalte Listenpreis finden
Finde = "*M" & Land & "1*"
If WF.CountIf(rng, Finde) > 0 Then
Spalte = WF.Match(Finde, rng, 0) + Offs
'Listenpreis kopieren
LC = TBL.Cells(1, TBL.Columns.Count).End(xlToLeft).Column + 1 'erste freie _
Spalte
.Columns(Spalte).Copy TBL.Columns(LC)
LC = LC + 1
'Spalte Umsatz finden
Finde = "AC Ext. Net Sales M" & Land & "1*"
If WF.CountIf(rng, Finde) > 0 Then
Spalte = WF.Match(Finde, rng, 0) + Offs
'Umsatz plus weitere Spalte kopieren
.Columns(Spalte).Resize(, Res).Copy TBL.Columns(LC)
Else
MsgBox "Umsatz für '" & Land & "' nicht gefunden"
ErrMeld = ErrMeld & ", " & Land
End If
Else
MsgBox "Listenpreis für '" & Land & "' nicht gefunden"
ErrMeld = ErrMeld & ", " & Land
End If
'Datei speichern
With WB
'Name festlegen Land_Datum_Uhrzeit
Datei = Pfad & Land & "_" & Format(Now, "YYYYMMDD_hhmmss") & Ext
.SaveAs Filename:=Datei, FileFormat:=xlOpenXMLWorkbook
.Close
End With
Next
End With
If ErrMeld "" Then
ErrMeld = vbLf & vbLf & Mid(ErrMeld, 3) & " unvollständig!"
End If
MsgBox "Fertig" & ErrMeld
End Sub