Folgende Aufgabenstellung:
In Abhängigkeit eines Kriteriums sollen Zellinhalte zu einem Text verkettet werden.
Vgl. Beispiel-Datei.
https://www.herber.de/bbs/user/62179.xls
Vielen Dank für eure Unterstützung.
TheMa
Sub tt()
Dim oDict As Object, arrKeys, arrItems, lngRow As Long, arrDaten()
Set oDict = CreateObject("scripting.dictionary")
For lngRow = 2 To Cells(Rows.Count, 4).End(xlUp).Row
If oDict.exists(Cells(lngRow, 4).Value) Then
oDict(Cells(lngRow, 4).Value) = oDict(Cells(lngRow, 4).Value) & Cells(lngRow, 3) & Cells( _
lngRow, 1)
Else
oDict.Add Cells(lngRow, 4).Value, Cells(lngRow, 3) & Cells(lngRow, 1)
End If
Next
arrKeys = oDict.keys
arrItems = oDict.items
ReDim arrDaten(1 To oDict.Count, 1 To 3)
For lngRow = 1 To oDict.Count
arrDaten(lngRow, 1) = arrKeys(lngRow - 1)
arrDaten(lngRow, 2) = Left(arrItems(lngRow - 1), Len(arrItems(lngRow - 1)) - 1)
arrDaten(lngRow, 3) = Len(arrDaten(lngRow, 2))
Next
Worksheets.Add
ActiveSheet.Cells(1, 1).Resize(oDict.Count, 3) = arrDaten
End Sub
Gruß
Rudi