|
Hallo,
danke hierfür, der Tip mit dem vorsortieren war der notwendige Input.
Ich habe das mitlerweile für beliebig viele Kriterien aufgesetzt und lasse meinen Ansatz mal folgen, sollte jemand mit ähnlichem Problem auf diesen Thread stoßen:
Dim wb As Workbook
Dim Zelle1 As Range
Dim Zelle2 As Range
With ActiveSheet
.UsedRange.Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes 'Vorstortieren
Set Zelle2 = .Cells(2, 1)
Set wb = Workbooks.Add(xlWBATWorksheet)
.Rows(1).Copy wb.Sheets(1).Cells(1, 1) 'Überschrift kopieren
Do
Set Zelle1 = Zelle2.Offset(1, 0)
If Zelle1.Text = "" Then Exit Do
Set Zelle2 = .Columns(1).Find(what:=Zelle1.Value, lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlPrevious)
Range(Zelle1, Zelle2).Resize(, 13).Copy wb.Sheets(1).Cells(2, 1) 'Daten kopieren, resize nach rechts
Application.DisplayAlerts = False 'überschreibt bestehende Dateien ohne Rückfrage
wb.SaveAs ThisWorkbook.Path & "\out\" & Zelle1.Value , FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
wb.Sheets(1).UsedRange.Offset(1, 0).Clear
Loop
wb.Close False
End With
MFG
|