Aus einer Excel-Datei pro Teilbestand eigene Exceldateien erzeugen

Eine Exceldatei mit einer Tabelle soll zu nach Feldinhalt einer bestimmten Spalte Teiltabellen inklusive Überschrift erzeugen und diese Teiltabellen als separate Exceldateien speichern, wobei im Dateinamen der Feldwert enthalten ist.

Hallo!

Mir liegt eine Exceldatei mit einer Tabelle vor. Die Spalten gehen von A bis BN, die Zeilen bis ca. 4500. Die oberste Zeile enthält die Überschriften. Die Überschrift der Spalte F lautet "Merkmal". Es gibt ca. 70 verschiedene Ausprägungen für "Merkmal" (z.B. 300, 2100, 2500 ...).

Von Hand würde ich jetzt pro Ausprägung für "Merkmal" den Autofilter bemühen, den jeweiligen Teilbestand inklusive Überschrift kopieren, eine neue leeren Exceldatei erzeugen, dort hinein den in der Zwischenablage kopierten Tabellenteil hineinkopieren und die neue Tabelle dann abspeichern mit dem Dateinamen "Serienbrief_" + Merkmalsausprägung + ".xls" (also Serienbrief_0300.xls, Serienbrief_2100.xls usw.).

Diese Art von Arbeit habe ich ein bis zweimal pro Jahr zu erledigen.

Hinsichtlich der Dateiformate habe ich keine Wahl. Es muss Excel sein. Mit Mitteln jenseits von Excel einzelne CSV-Dateien zu erzeugen, wäre für mich kein Problem. Aber ich bin in diesem Fall gebunden.

Die Ausgangstabelle ist schon nach "Merkmal" sortiert. Sofern von den neuen Tabellen bereits welche mit gleichem Dateinamen bestehen sollen diese entweder überschrieben werden oder kann die ganze Aktion mit einer Fehlermeldung abbrechen.

Gibt es eine halbwegs einfache Lösung, das einigermaßen elegant und vor allem automatisiert in einem Rutsch hinzubekommen? Wenn ja, wie ungefähr?

Vielen Dank!

Gruß

Delcour

Sub Copy2newfile()
    zeile = 2
    Do
        ' Bereich kopieren  
        altezeile = zeile + 1
        zeile = zeile + 1
        Merkmal = Range("F" & zeile).Value  
        Do While Range("F" & zeile).Value = Merkmal  
            zeile = zeile + 1
        Loop
        zeile = zeile - 1
        Range("A" & altezeile & ":BN" & zeile).Copy  
        
        ' In neue Datei einfügen  
        Workbooks.Add
        ActiveSheet.Paste
        
        'Speichern udn schliessen  
        ActiveWorkbook.SaveAs Filename:= _
            "D:\Serienbrief_" & Merkmal & ".xls", _  
            FileFormat:=xlNormal, Password:="", WriteResPassword:="", _  
            ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWindow.Close
    Loop While Range("F" & zeile + 1).Value <> ""  
End Sub

Sub Copy2newfile()
    zeile = 2
    aKopf = Range("A1:BN1")  
    Do
        ' Bereich kopieren  
        altezeile = zeile + 1
        zeile = zeile + 1
        Merkmal = Range("F" & zeile).Value  
        Do While Range("F" & zeile).Value = Merkmal  
            zeile = zeile + 1
        Loop
        zeile = zeile - 1
        Range("A" & altezeile & ":BN" & zeile).Copy  
        
        ' In neue Datei einfügen  
        Workbooks.Add
        ActiveSheet.Range("A1:BN1") = aKopf  
        ActiveSheet.Range("A2").Select  
        ActiveSheet.Paste
        
        'Speichern und schließen  
        ActiveWorkbook.SaveAs "D:\Serienbrief_" & Merkmal & ".xls"  
        ActiveWindow.Close
    Loop While Range("F" & zeile + 1).Value <> ""  
End Sub