Filtern Speichern in extra Dateien

Hallo zusammen,
ich benötige ein Makro und habe es versucht aufzunehmen aber komme damit nur bedingt an meine ziel.
Ich habe eine Datei mit ca. 150 Kriterien in Spalte B.
Ich möchte das nacheinander alle Kriterien gefiltert werden und eine Datei mit den gefilterten Werten gespeichert wird. Ich stelle mir das so vor.
Es wird die in Spalte B die 1 gefiltert und die Daten die unter 1 angezeigt werden komplett mit Filter und Format in eine neue Datei gespeichert mit der Bezeichnung 1 und dem aktuellen Datum. So das ich in meine Fall 150 Dateien erhalte. Wichtig ist noch, dass es ein zweites Tab gibt, was immer gleich ist aber mit jeder Datei gespeichert werden soll.
Für Jede Hilfe wäre ich sehr dankbar.
Vielen Dank.
Beste Grüße
Denny

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
in ein normales Modul...
Modul1

Option Explicit 
 
Sub Denny() 
    Dim WB, TB, TMP, TBN, Pfad As String, LR As Integer, i As Integer, Datei As String, Ext As String 
         
    '*** bescheunigt das Makro 
    Application.ScreenUpdating = False 
 
    Set TB = Sheets("Tabelle1") 
    Pfad = "x:\Temp\test\" 
    Ext = ".xlsx" 
     
    If TB.AutoFilterMode Then TB.AutoFilterMode = False ' Autofilter ausschalten 
     
    'temp. Blatt anlegen 
    Set TMP = Sheets.Add(After:=Sheets(Sheets.Count)) 
     
    'copieren 
    TB.Columns(2).Copy TMP.Columns(1) 
     
    With TMP 
        .Range("$A:$A").RemoveDuplicates Columns:=1, Header:=xlYes 
     
        'sortieren 
        With .Sort 
            .SortFields.Clear 
            .SortFields.Add Key:=Range("A1"), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 
            .SetRange Range("A:A") 
            .Header = xlYes 
            .MatchCase = False 
            .Orientation = xlTopToBottom 
            .SortMethod = xlPinYin 
            .Apply 
        End With 
         
        LR = .Cells(.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte 
 
    End With 
 
    With TB 
         
        For i = 2 To LR 
            Datei = TMP.Cells(i, 1) 
             
            'filtern 
            .Range("$B:$B").AutoFilter Field:=1, Criteria1:=Datei 
     
            'Neues Blatt 
            Set TBN = Sheets.Add(After:=Sheets(Sheets.Count)) 
             
            'Kopieren der gefilterten Daten 
            .UsedRange.Copy TBN.Cells(1, 1) 
             
            'umbenennen 
            TBN.Name = Datei 
             
            'verschieben in eigene Datei 
            TBN.Move 
             
            'Speichern und schließen 
            With ActiveWorkbook 
                .SaveAs Filename:=Pfad & Datei & "_" & Format(Date, "YYYY_MM_DD") & Ext, _
                    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 
                 
                .Close 
            End With 
        Next 
     
        .AutoFilterMode = False 
     
    End With 
     
    'temp. Blatt löschen 
    With Application 
        .DisplayAlerts = False 
        TMP.Delete 
        .DisplayAlerts = True 
    End With 
     
End Sub

LG UweD

Beliebteste Forumthreads (12 Monate)

Filtern Speichern in extra Dateien

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread