Datensätze auf mehrere Dateien aufteilen

Hallo Experten,
ich hab das Makro im Forum gefunden und es läuft auch ganz gut, aber eben nur für jeweils einen Datensatz.
Kann mir jemand den Code so anpassen, dass es immer 500 Datensätze kopiert und daraus eine neue Datei macht.
Die Grundtabelle hat über 25.000 Datensätze.
Wäre klasse, wenn da jemand eine gute Idee hat.
VG aus Bayern
Elmar

Sub Aufteilen()
Dim Zelle1 As Range, Zelle2 As Range
Dim wb As Workbook
Dim Pfad As String
Pfad = "C:\Daten\Virtueller Scan\Aufteilungen"
With ActiveSheet
'--- Quelltabelle sortieren
.UsedRange.Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes
'--- neue leere Datei anlegen, Überschriften und Spaltenbreiten übernehmen
Set wb = Workbooks.Add(xlWBATWorksheet)
.UsedRange.Copy
wb.Sheets(1).PasteSpecial xlPasteColumnWidths
.Rows(1).Copy Destination:=wb.Sheets(1).Cells(1, 1)
'--- Daten übernehmen
Set Zelle1 = .Cells(2, 1)
Do Until Zelle1.Value = ""
'--- Kriterium letzte Zeilen finden
Set Zelle2 = .Columns(1).Find(what:=Zelle1.Value, _
lookat:=xlWhole, LookIn:=xlValues, _
searchdirection:=xlPrevious)
'--- Zieltabelle leeren
wb.Sheets(1).UsedRange.Offset(1, 0).Clear
'--- Daten kopieren
Range(Zelle1, Zelle2).EntireRow.Copy Destination:=wb.Sheets(1).Cells(2, 1)
'--- Speichern
wb.SaveAs Pfad & "\" & Zelle1.Value, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'--- nächstes Kriterium erste Zeile finden
Set Zelle1 = Zelle2.Offset(1, 0)
Loop
wb.Close
End With
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub SplitIntoMultipleFiles() Dim wb As Workbook Dim ws As Worksheet Dim rng As Range Dim i As Long Dim j As Long Dim k As Long Dim lRow As Long Dim sFileName As String 'Ändern Sie diesen Pfad, um den Ordner zu ändern, in dem die Dateien gespeichert werden sollen Const sPath As String = "C:\temp\" Set wb = ThisWorkbook Set ws = wb.Sheets("Sheet1") 'Ändern Sie "Sheet1" in den Namen der gewünschten Arbeitsblatt lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row k = 1 For i = 1 To lRow Step 500 Set rng = ws.Range("A" & i & ":A" & i + 499) sFileName = sPath & "File" & k & ".xlsx" k = k + 1 'Erstelle ein neues Arbeitsbuch und kopiere die Zeilen Set wb = Workbooks.Add rng.Copy wb.Sheets(1).Range("A1") wb.SaveAs sFileName, xlOpenXMLWorkbook wb.Close Next i End Sub

Sub Zeile_to_Sheet() Dim WS As Worksheet, Sht As Worksheet Set WS = ActiveSheet For i = 2 To WS.Cells(Rows.Count, 1).End(xlUp).Row Step 50 Set Sht = Sheets.Add(, Sheets(Sheets.Count)) WS.Cells(i, 1).Resize(50).Copy Sht.Cells(2, 1) Sht.Cells(1, 1) = WS.Cells(1, 1) Next i End Sub

Beliebteste Forumthreads (12 Monate)

Datensätze auf mehrere Dateien aufteilen

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread