Sub VerketteBinC()
Dim wsh As Worksheet
Dim rngRow As Range
Dim rngDataRow As Range
Dim colData As New Collection
Set wsh = ActiveWorkbook.Worksheets(1)
For Each rngRow In wsh.UsedRange.Rows
If rngRow.Row > 1 Then
If Not IsEmpty(rngRow.Cells(1, 1).Value) Then
SaveData rngDataRow, colData
Set rngDataRow = rngRow
Set colData = New Collection
ElseIf Not rngDataRow Is Nothing Then
AddItem colData, rngRow.Cells(1, 2), rngRow.Cells(1, 3)
End If
End If
Next
SaveData rngDataRow, colData
End Sub
Sub SaveData(ByRef rng As Range, ByRef colData As Collection)
Dim iCol As Integer
Dim sColName As String
If Not rng Is Nothing Then
For iCol = 1 To colData.Count
For iColumn = 1 To rng.Columns.Count
If rng.Worksheet.Cells(1, iColumn).Value = colData.Item(iCol).Item(1) Then
rng.Cells(1, iColumn) = colData.Item(iCol).Item(2)
Exit For
End If
Next
Next
End If
End Sub
Sub AddItem(ByRef colData As Collection, ByVal sTag As String, sValue As String)
Dim iCol As Integer
Dim colItem As New Collection
colItem.Add Item:=sTag
For iCol = 1 To colData.Count
If colData.Item(iCol).Item(1) = colItem.Item(1) Then
sValue = colData.Item(iCol).Item(2) & ", " & sValue
colData.Remove (iCol)
Exit For
End If
Next
colItem.Add Item:=sValue
colData.Add colItem
End Sub