Hallo zusammen,

mein Problem ist ein ähnliches:

wie kann ich denn in einer Excel-Datei nach einer bestimmten "Anzahlschritten" jeweilst neue Dateien generieren. Bisher habe ich folgendes Makro gefunden, dass aber nur nach gleichnamigen Werten in Spalte A prüft und diese dann in Dateien splittet:

Public Sub aufteilen()

    Dim objDictionary As Object
    Dim objCell As Range, objCopyRange As Range
    Dim objWorkbook As Workbook
    Dim ialngIndex As Long
    Dim avntValues As Variant, avntKeys As Variant
    Dim strFirstAddress As String
    Application.ScreenUpdating = False
    With Tabelle1
        avntValues = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Value2
    End With
    Set objDictionary = CreateObject("Scripting.Dictionary")
    For ialngIndex = LBound(avntValues) To UBound(avntValues)
        objDictionary(avntValues(ialngIndex, 1)) = vbNullString
    Next
    avntKeys = objDictionary.Keys
    Set objDictionary = Nothing
    With Tabelle1
        For ialngIndex = LBound(avntKeys) To UBound(avntKeys)
            Set objCell = .Columns(1).Find(What:=avntKeys(ialngIndex), _
                LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
            If Not objCell Is Nothing Then
                strFirstAddress = objCell.Address
                Set objCopyRange = .Cells(1, 1)
                Do
                    Set objCopyRange = Union(objCopyRange, objCell)
                    Set objCell = .Columns(1).FindNext(objCell)
                Loop Until objCell.Address = strFirstAddress
                Set objWorkbook = Workbooks.Add(xlWBATWorksheet)
                objCopyRange.EntireRow.Copy Destination:=objWorkbook.Worksheets(1).Cells(1, 1)
                objWorkbook.Close SaveChanges:=True, Filename:= _
                    ThisWorkbook.Path & "\" & avntKeys(ialngIndex) & ".xls"
                Set objWorkbook = Nothing
                Set objCell = Nothing
                Set objCopyRange = Nothing
            End If
        Next
    End With
    Application.ScreenUpdating = True

End Sub

Danke für Feedback!

Gruß Sino