AW: Listen ausgeben
06.05.2008 00:47:36
Daniel
Hallo
hier mal 2 Beispielcodes, einmal für Aufteilen in neue Sheets und einmal Aufteilen in neue Workbooks (mit Speichern)
da beim Erstellen der Listen die Ausgangsdaten gelöscht werden, musst du zum Rumspielen immer wieder die Tabelle von der Original in die Ausgangsliste koperen:
https://www.herber.de/bbs/user/52120.xls
und der Code dazu
Sub aufteilen_Sheet()
Dim shQ As Worksheet
Dim shZ As Worksheet
Dim strFi As String
Dim ze1 As Long
Const spFi As Long = 1
Set shQ = Sheets("Ausgangsliste")
shQ.Cells(1, 1).CurrentRegion.Sort key1:=shQ.Cells(2, spFi)
With shQ
Do Until .Cells(2, spFi).Value = ""
strFi = .Cells(2, spFi).Value
Set shZ = Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
shZ.Name = strFi
ze1 = .Columns(spFi).Find(what:=strFi, after:=.Cells(Rows.Count, spFi), searchdirection:= _
xlPrevious).Row
Range(.Cells(1, 1), .Cells(ze1, 1)).EntireRow.Copy Destination:=shZ.Cells(1, 1)
Range(.Cells(2, 1), .Cells(ze1, 1)).EntireRow.Delete
Loop
End With
End Sub
Sub aufteilen_Workbook()
Dim shQ As Worksheet
Dim wbZ As Workbook
Dim shZ As Worksheet
Dim strFi As String
Dim ze1 As Long
Const spFi As Long = 1
Set shQ = ThisWorkbook.Sheets("Ausgangsliste")
shQ.Cells(1, 1).CurrentRegion.Sort key1:=shQ.Cells(2, spFi)
With shQ
Do Until .Cells(2, spFi).Value = ""
strFi = .Cells(2, spFi).Value
Set wbZ = Workbooks.Add
Set shZ = wbZ.Sheets(1)
shZ.Name = strFi
ze1 = .Columns(spFi).Find(what:=strFi, after:=.Cells(Rows.Count, spFi), searchdirection:= _
xlPrevious).Row
Range(.Cells(1, 1), .Cells(ze1, 1)).EntireRow.Copy Destination:=shZ.Cells(1, 1)
Range(.Cells(2, 1), .Cells(ze1, 1)).EntireRow.Delete
wbZ.SaveAs ThisWorkbook.Path & "\" & strFi & ".xls"
wbZ.Close
Loop
End With
End Sub
Gruß, Daniel