Pro Eintrag in Tabellenblatt eine neue Datei erstellen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Maurice,
teste mal:

Option Explicit

Public Sub Splitten()

    Dim avntValues As Variant, vntItem As Variant
    Dim objDictionary As Object
    Dim objWorkbook As Workbook

    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    With Tabelle1 ' Anpassen !!!
        avntValues = .Range(.Cells(2, 4), .Cells(.Rows.Count, 4).End(xlUp)).Value2
    End With

    Set objDictionary = CreateObject(Class:="Scripting.Dictionary")

    With objDictionary

        For Each vntItem In avntValues

            .Item(Key:=vntItem) = vbNullString

        Next

        For Each vntItem In .Keys

            Set objWorkbook = Workbooks.Add(Template:=xlWBATWorksheet)

            With Tabelle1 ' Anpassen !!!

                Call .Rows(1).AutoFilter(Field:=4, Criteria1:=vntItem)

                Call .AutoFilter.Range.Copy(Destination:= _
                    objWorkbook.Worksheets(1).Cells(1, 1))

            End With

            Call objWorkbook.SaveAs(Filename:=ThisWorkbook.Path & "\" & _
                CStr(vntItem), FileFormat:=xlOpenXMLWorkbook)

            Call objWorkbook.Close(SaveChanges:=False)

        Next
    End With

    Call Tabelle1.ShowAllData ' Anpassen !!!

    Set objWorkbook = Nothing
    Set objDictionary = Nothing

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Überall wo Anpassen steht musst du den Objektnamen der Datentabelle eintragen. Das ist der Name der im Projektexplorer vor dem in Klammern stehenden Namen auf der Exceloberfläche steht.
Die entstehenden Dateien werden im selben Pfad gespeichert in dem sich die Ursprungsmappe befindet.
Gruß
Nepumuk

Option Explicit Sub Kunden() Dim TB1 As Worksheet, TB2 As Worksheet, TBTmp As Worksheet, LR As Integer, i As Integer Dim RngDaten As Range, RngKrit As Range, RngZiel As Range Dim Pfad As String, Kunde As String Pfad = "X:\Temp\" 'mit \ am Ende Set TB1 = Sheets("Tabelle1") Set TBTmp = Sheets.Add(After:=TB1) With TBTmp ' temporäres Blatt anlegen .Name = "TMP" 'Kunden kopieren TB1.Columns("D:D").Copy .Cells(1, 1) 'Doppelte entfernen .Columns(1).RemoveDuplicates Columns:=1, Header:=xlYes LR = .Cells(.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte End With For i = 2 To LR Kunde = TBTmp.Cells(2, 1) 'Kundenblatt anlegen Set TB2 = Sheets.Add(After:=TB1) TB2.Name = "Kunde " & Kunde 'Filter festlegen Set RngDaten = TB1.Range("A1").CurrentRegion Set RngKrit = TBTmp.Range("A1:A2") 'die oberen 2 Werte von temp Set RngZiel = TB2.Cells(1, 1) RngDaten.AdvancedFilter xlFilterCopy, RngKrit, RngZiel 'Blatt als eigene Datei TB2.Move 'Neue Datei speichern und schließen With ActiveWorkbook .SaveAs Filename:=Pfad & "Kunde " & Kunde & ".xlsx", FileFormat:=xlOpenXMLWorkbook .Close End With 'auf nächste Kundennummer wechseln TBTmp.Rows(2).Delete xlUp Next 'Temp. Blatt wieder löschen Application.DisplayAlerts = False TBTmp.Delete End Sub

Beliebteste Forumthreads (12 Monate)

Pro Eintrag in Tabellenblatt eine neue Datei erstellen

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

313 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Pro Eintrag in Tabellenblatt eine neue Datei erstellen

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

313 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread