Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1696to1700
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Excel Datei splitten und tabs kopieren

Excel Datei splitten und tabs kopieren
18.06.2019 15:46:35
Zdravko
Hallo Zusammen,
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

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Excel Datei splitten und tabs kopieren
18.06.2019 16:06:51
UweD
Hallo nochmal
so?
Option Explicit



Sub Aufteilen_Länder()
    Dim Land, Arr(), WB1, TB1, WBL, 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 WB1 = ThisWorkbook
    Set TB1 = WB1.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 WBL = Workbooks.Add
            Set TBL = WBL.Sheets(1)
            
            'immer kopieren 
            .Columns(1).Resize(, Offs).Copy TBL.Columns(1)
            WB1.Sheets(Array("Tabelle1", "Tabelle2", "Tabelle3", "Tabelle4")).Copy after:=WBL.Sheets(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 WBL
                '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
LG UweD
Anzeige
AW: Excel Datei splitten und tabs kopieren
19.06.2019 09:39:39
Zdravko
Guten Morgen Uwe,
vielen Dank für die schnelle Hilfe. Die einfachsten Lösungen sind doch die besten. Ich hatte mir was überlegt, es aber an der falschen Stelle eingefügt und zwar nach der Zeile Set TB1. Mein Statement war auch über 4 Zeilen lang und lief immer auf Fehler. Deine Lösung ist viel eleganter und besser umzusetzen!
Eeinen schöne Tag dir und ein erholsames langes Wochenende hoffentlich!
Gruß Zdravko
Prima! Danke für die Rückmeldung. owT
19.06.2019 10:35:01
UweD

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige