Macro for Intelligent Transpose - vba

Question

So currently, per the title, I'm looking to make a smart and relatively automatic transpose system.
So far the only way I've figured out how to do this is with macros, paste special, and a lot of manual work (working on 2,000~ row sheet).
The following example is an example.
All the events belong to A1 but are distributed downwards in a new row. The goal is to have them all in a single row (either in a single cell or adjacent).
A Event 1
A Event 2
A Event 3
B Group 1
B Group 2
All the events belong to A1 but are distributed downwards in a new row. The goal is to have them all in a single row (either in a single cell or adjacent).
The example of how I need them is demonstrate below.
A Event 1 Event 2 Event 3
B Group 1 Group 2
I have searched far and wide and haven't found anything which solves this bizarre request.

Answer 1

You can do this quite easily using a dictionary. Have a look at the following. You will need to update the two With blocks with your input and destination range
Public Sub test()
Dim dict As Object
Dim arr As Variant, tmp As Variant
Dim i As Long
Dim key
Set dict = CreateObject("Scripting.Dictionary")
' Source Data
With Sheet1
arr = .Range(.Cells(1, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "B")).Value2
End With
For i = LBound(arr, 1) To UBound(arr, 1)
If Not IsEmpty(tmp) Then Erase tmp
If dict.exists(arr(i, 1)) Then
tmp = dict(arr(i, 1))
ReDim Preserve tmp(LBound(tmp) To UBound(tmp) + 1)
tmp(UBound(tmp)) = arr(i, 2)
dict(arr(i, 1)) = tmp
Else
ReDim tmp(0)
tmp(LBound(tmp)) = arr(i, 2)
dict.Add key:=arr(i, 1), Item:=tmp
End If
Next i
' Destination
With Sheet1.Cells(1, 5)
i = 0
For Each key In dict.keys
.Offset(i, 0) = key
'' Side by side
Range(.Offset(i, 1), .Offset(i, UBound(dict(key)) + 1)).Value2 = dict(key)
'' In one cell
'.Offset(i, 1).Value2 = Join(dict(key), ",")
i = i + 1
Next key
End With
End Sub

Answer 2

Say we have data in columns A and B like:
Running this code:
Sub Macro1()
Dim Na As Long, Nd As Long, rc As Long
Dim i As Long, j As Long, K As Long
Dim v As Variant
Range("A:A").Copy Range("D:D")
Range("D:D").RemoveDuplicates Columns:=1, Header:=xlNo
rc = Rows.Count
K = 5
Na = Cells(rc, "A").End(xlUp).Row
Nd = Cells(rc, "D").End(xlUp).Row
For i = 1 To Nd
v = Cells(i, "D")
For j = 1 To Na
If v = Cells(j, 1) Then
Cells(i, K) = Cells(j, 2)
K = K + 1
End If
Next j
K = 5
Next i
End Sub
will produce: