Sub TestRoute()
'im Test stehen die Werte in Spalte A untereinander
'in Zelle A1 der erste Begriff = "Route"
'
'Achtung, es werden Zeilen gelöscht - sichere deine Daten!
'
Dim rng As Range, RngA As Range
Dim arr() As Variant
Dim x As Long, y As Long, ax As Long
Dim Str As String
Application.ScreenUpdating = False
With Columns(1)
Set rng = .Range(.Cells(1), .Cells(.Rows.Count, 1).End(xlUp))
arr = rng.Value
'
Set RngA = .ColumnDifferences(Comparison:=.Range("A1"))
'
For x = 1 To RngA.Areas.Count
Str = ""
ax = ax + 1
arr(ax, 1) = .Range("A1").Value
For y = RngA.Areas(x).Cells(2).Row To RngA.Areas(x).Cells(RngA.Areas(x).Cells.Count).Row
Str = Str & Chr(32) & .Cells(y, 1).Value
Next y
RngA.Areas(x).Cells(1).Value = RngA.Areas(x).Cells(1).Value & Str
ax = ax + 1
arr(ax, 1) = RngA.Areas(x).Cells(1).Value
Next x
'
For x = ax + 1 To UBound(arr, 1)
arr(x, 1) = ""
Next x
Set rng = .Cells(1)
rng.Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
'
End With
Application.ScreenUpdating = True
End Sub
|