AW: Werte Aufliste
09.05.2019 09:36:00
Nepumuk
Hallo Daniel,
teste mal:
Option Explicit
Public Sub Verdichten()
Dim avntValues As Variant
Dim ialngIndex As Long
Dim objDictionary As Object
With Worksheets("Tabelle1") 'Tabellenname anpassen
avntValues = .Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(xlUp)).Value2
End With
Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
With objDictionary
For ialngIndex = LBound(avntValues, 1) To UBound(avntValues, 1)
If .Exists(Key:=avntValues(ialngIndex, 1)) Then
.Item(Key:=avntValues(ialngIndex, 1)) = _
.Item(Key:=avntValues(ialngIndex, 1)) & _
", " & avntValues(ialngIndex, 2)
Else
Call .Add(Key:=avntValues(ialngIndex, 1), _
Item:=avntValues(ialngIndex, 2))
End If
Next
Worksheets("Tabelle1").Cells(1, 3).Resize(.Count, 1).Value = _
Application.Transpose(.Keys)
Worksheets("Tabelle1").Cells(1, 4).Resize(.Count, 1).Value = _
Application.Transpose(.Items)
End With
Set objDictionary = Nothing
End Sub
Gruß
Nepumuk