|
Hallo,
und das wundert dich jetzt, dass er nicht funktioniert?
Dein Tabellenaufbau weicht ja wohl doch von deiner Eingangsbeschreibung ab. Dort steht was von Daten ab Spalte A, jetzt sind aber wohl doch erst Daten ab Spalte B vorhanden.
Option Explicit
Public Sub Verteilen()
Dim varArray As Variant, varItem As Variant, objDic As Object
Application.ScreenUpdating = False
Set objDic = CreateObject("Scripting.Dictionary")
With Worksheets("Tabelle1")
varArray = .Range("E2:E" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value
With objDic
For Each varItem In varArray
.Item(Key:=varItem) = vbNullString
Next
End With
For Each varItem In objDic.keys
.Range("B1").AutoFilter field:=4, Criteria1:=varItem
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Copy
End With
With Worksheets(varItem)
.Cells(.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row, "A") _
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
Next varItem
.Range("B1").AutoFilter
End With
Set objDic = Nothing
Application.CutCopyMode = False
End Sub
Gruß Werner
|