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
Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden
Suche nach den besten AntwortenEntdecke unsere meistgeklickten Beiträge in der Google Suche
Top 100 Threads jetzt ansehen