Werte verteilen!

Eine Liste soll auf mehrere Tabellenblätter aufgeteilt werden. Die Kriterienspalte ist Spalte A. Die Überschriftenzeile soll auf jedem Tabellenblatt erscheinen. Bei erneutem ausführen des Makros sollen die angelegten Tabellenblätter zuerst gelöscht werden. Es gibt dazu zwei Beispielcodes und eine Beispieldatei:

Liste auf mehrere Tabellenblätter aufteilen... [ZIP, 60 KB]

Dann noch ein Link auf das Thema - dort gibt es auch Formellösungen:

Liste aufteilen...

Code1:

Option Explicit
Public Sub Aufteilen()
Dim wksSheet As Worksheet
Dim wksTMP As Worksheet
Dim rngRange As Range
Dim rngTMP As Range
Dim lngRow As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
For Each wksTMP In ThisWorkbook.Worksheets
If wksTMP.Name Like "Klasse*" Then
wksTMP.Delete
End If
Next wksTMP
Set wksSheet = ThisWorkbook.Worksheets("Gesamt")
With wksSheet
Set rngRange = .Range("A1").CurrentRegion
rngRange.Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes
lngRow = 2
Do Until IsEmpty(rngRange.Cells(lngRow, 1))
If rngRange.Cells(lngRow, 1) <> rngRange.Cells(lngRow - 1, 1) Then
rngRange.AutoFilter field:=1, _
Criteria1:=rngRange.Cells(lngRow, 1)
Set rngTMP = rngRange.SpecialCells(xlCellTypeVisible)
Worksheets.Add.Move After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Klasse_" & rngRange.Cells(lngRow, 1)
rngTMP.Copy Range("A1")
End If
lngRow = lngRow + 1
Loop
End With
Fin:
wksSheet.AutoFilterMode = False
With Application
.Goto wksSheet.Range("A1"), True
.ScreenUpdating = True
.DisplayAlerts = True
End With
Set rngRange = Nothing
Set wksSheet = Nothing
End Sub



Code2:

Option Explicit
Public Sub Aufteilen_1()
Dim wksKriterienSheet As Worksheet
Dim wksQuellSheet As Worksheet
Dim rngKriterium As Range
Dim wksNew As Worksheet
Dim wksTMP As Worksheet
Dim lngLastRow As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
For Each wksTMP In ThisWorkbook.Worksheets
If wksTMP.Name Like "#*" Then
wksTMP.Delete
End If
Next wksTMP
' Tabellenblatt mit Daten - Name ANPASSEN
Set wksQuellSheet = Worksheets("Gesamt")
Set wksKriterienSheet = Worksheets.Add
wksKriterienSheet.Move After:= _
ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
lngLastRow = wksQuellSheet.Range("A" & Rows.Count).End(xlUp).Row
wksQuellSheet.Range("A1:A" & lngLastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=wksKriterienSheet.Range("A1"), Unique:=True
Set rngKriterium = wksKriterienSheet.Range("A2")
While rngKriterium.Value <> ""
Set wksNew = Worksheets.Add
wksQuellSheet.Range("A1:N" & lngLastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngKriterium.Offset(-1).Resize(2), _
CopyToRange:=wksNew.Range("A1"), Unique:=True
wksNew.Name = rngKriterium.Text
rngKriterium.EntireRow.Delete
Set rngKriterium = wksKriterienSheet.Range("A2")
Wend
wksKriterienSheet.Delete
Fin:
With Application
.Goto wksQuellSheet.Range("A1"), True
.ScreenUpdating = True
.DisplayAlerts = True
End With
Set wksKriterienSheet = Nothing
Set wksQuellSheet = Nothing
Set rngKriterium = Nothing
Set wksNew = Nothing
End Sub

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...