|
Hallo,
und warum jetzt einen neuen Beitrag?
Aber was solls. Würde ich mit Scripting Dictionary und dem Autofilter lösen.
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("A1").AutoFilter field:=5, 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("A1").AutoFilter
End With
Set objDic = Nothing
Application.CutCopyMode = False
End Sub
Gruß Werner
|