AW: Doppelte Werte erweitern
23.09.2021 17:52:15
Daniel
Hi
da du nach einer reinen VBA-Lösung gefragt hast, probier mal das als alternative zum Formelansatz von Chris:
Sub test()
Dim arr, arr2
Dim dic
Dim z As Long
Set dic = CreateObject("Scripting.dictionary")
With Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
arr = .Value
arr2 = .Value
For z = 1 To UBound(arr, 1)
dic(arr(z, 1)) = dic(arr(z, 1)) + 1
arr(z, 1) = arr(z, 1) & Split(Columns(dic(arr(z, 1))).Address(0, 0), ":")(1)
Next
For z = 1 To UBound(arr2, 1)
If dic(arr2(z, 1)) = 1 Then arr(z, 1) = arr2(z, 1)
Next
.Value = arr
End With
End Sub
bei großen Datenmengen (mehrere Tausend Zeilen) dürfte das etwas schneller sein.
außerdem verarbeitet das Makro auch mehr als 26 wiederholungen, mit dem Weg über die Spaltenadressen wird nach Z mit AA weitergemacht.
Gruß Daniel