AW: VBA Mehrere Zellen in eine Zelle übertr.
18.10.2021 07:14:20
ralf_b
der jetzige Stand, entspricht nicht der ursprünglichen Vorgabe. Aber das weist du ja selbst. Nepumuk's Lösung ist nicht für eine lückenhafte Wertespalte geschrieben.
versuchs mal damit.
Public Sub TextJoin()
Dim lngRow As Long
Dim vntItem As Variant
Dim objDictionary As Object
Dim lmerken As Long
Dim bstop As Boolean
Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
With objDictionary
For lngRow = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(lngRow, 1).Text = "" Then
If bstop = False Then bstop = True: lmerken = lngRow - 1
Else
bstop = False
lmerken = lngRow
End If
If .Exists(Key:=Cells(lmerken, 1).Text) Then
.Item(Key:=Cells(lmerken, 1).Text) = .Item(Key:=Cells(lmerken, 1).Text) & " " & Cells(lngRow, 2).Text
Else
Call .Add(Key:=Cells(lmerken, 1).Text, Item:=Cells(lngRow, 2).Text)
End If
Next
lngRow = 1
For Each vntItem In .Keys
Cells(lngRow, 4).Value = vntItem
Cells(lngRow, 5).Value = .Item(Key:=vntItem)
lngRow = lngRow + 1
Next
End With
Set objDictionary = Nothing
End Sub