The following code performs the following:
From:
word1 ; word_a
word1 ; word_b
word2 ; word_c
word2 ; word_d
word2 ; word_e
To:
word1 ; word_a ; word_b
word2 ; word_c ; word_d ; word_e
word3 ; word_f
Sub x()
Dim rInput As Range, oDic As Object, sNames() As String, vInput()
Dim i As Long, nIndex As Long
Set rInput = Range("A1", Range("B65536").End(xlUp))
vInput = rInput.Value
ReDim sNames(1 To UBound(vInput, 1), 1 To 2)
Set oDic = CreateObject("Scripting.Dictionary")
With oDic
For i = 1 To UBound(vInput, 1)
If Not .Exists(vInput(i, 1)) Then
nIndex = nIndex + 1
sNames(nIndex, 1) = vInput(i, 1)
sNames(nIndex, 2) = vInput(i, 2)
.Add vInput(i, 1), nIndex
ElseIf .Exists(vInput(i, 1)) Then
sNames(.Item(vInput(i, 1)), 2) = sNames(.Item(vInput(i, 1)), 2) & ", " & vInput(i, 2)
End If
Next i
End With
Cells(1, "H").Resize(nIndex, 2) = sNames
' The line below if you want the words in separate columns
' otherwise they are in a single cell, separated by commas
Cells(1, "I").Resize(nIndex).TextToColumns , comma:=True
End Sub
However I want the ability to transpose two columns i.e. word_a and word_1
From:
word1 ; word_a, word_1
word1 ; word_b, word_2
To:
word1 ; word_a ; word_1;word_b;word_2
Can anyone help?
Bookmarks