Anzeige
Archiv - Navigation
1736to1740
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

Pro Eintrag in Tabellenblatt eine neue Datei erstellen

Pro Eintrag in Tabellenblatt eine neue Datei erstellen
03.02.2020 16:04:09
Maurice
Hallo zusammen,
ich habe eine Datei mit ca. 850 Zeilen und ich brauche pro Kunde eine neue Datei.
Die Datei ist wie folgt aufgebaut
Monat | Datum | Produkt | Kunde
12 31.12.19 Schrauben 456
12 31.12.19 Tische 456
12 31.12.19 Stühle 999
Nun muss pro Kunde eine Datei erststellt und mit dem Kundennamen gespeichert werden.
In dem Beispiel -
Datei Kunde 456.xls
Monat | Datum | Produkt | Kunde
12 31.12.19 Schrauben 456
12 31.12.19 Tische 456
Datei Kunde 999.xls
Monat | Datum | Produkt | Kunde
12 31.12.19 Stühle 999
Ich habe bis jetzt noch nicht so viel in VBA programmiert, sodass mir den Ansatz total fehlt..
Vielleicht kann von euch jemand helfen?
VIelen Dank und Grüße
Maurice

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

Betreff
Datum
Anwender
Anzeige
AW: Pro Eintrag in Tabellenblatt eine neue Datei erstellen
03.02.2020 16:50:33
Nepumuk
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
Anzeige
AW: Pro Eintrag in Tabellenblatt eine neue Datei erstellen
03.02.2020 17:35:38
Maurice
Nepumuk ich danke dir!! Richtig gut! Wenn ich es jetzt noch verstehen würde, wäre ich froh :)!
Dieses objDictionary muss ich mir mal angucken.
AW: Pro Eintrag in Tabellenblatt eine neue Datei erstellen
03.02.2020 17:08:09
UweD
Hallo
so?
Modul1
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 

LG UweD
Anzeige
AW: Pro Eintrag in Tabellenblatt eine neue Datei erstellen
03.02.2020 17:36:43
Maurice
Uwe deins gucke ich mir auch noch! Auch dir vielen Dank
Crosspost ohne Hinweis...
03.02.2020 21:19:58
Werner
Hallo,
...und obwohl hier gelöst, muss man das nicht im VBA-Forum mitteilen.
Dort darf sich dann gerne auch damit beschäftigen und für die Tonne arbeiten-
Gruß Werner
AW: Crosspost ohne Hinweis...
03.02.2020 21:32:16
Maurice
Sorry, ich habe einfach nicht grad gedacht. Kommt nicht wieder vor.

313 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige