Hallo,

habe folgendes Makro gefunden, dass mir alle gleichen Werte in Spalte A in neue Dateien aufteilt. Meine Frage ist, wie kann ich den Code denn modifizieren, um beispielsweise nach allen 100 Zeilen jedesmal aufzuteilen und ne neue Datei erstellen:

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

Thx for help!

Gruß Rasti