Macro for Intelligent Transpose

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.

If this would be for a single file, power query would be able to do that (assuming that the a/b categorization is in one column and the event names in another). If looking at repeated use and/or a different file. Perhaps a macro which selects the data and creates a PQ? I haven't really gone that far before, so I'm not sure how generalized you could make it... **Note:** If you're looking for someone to do all the work for you, this is not the site for you. — Mistella, Apr 12 '18 at 15:08
Have a look at that answer I gave at [*Combining consecutive values in a column with the help of VBA*](https://stackoverflow.com/a/48439700/3219613) the task is pretty similar and can easily be adapted to yours. Otherwise please read http://idownvotedbecau.se/noattempt/ — Pᴇʜ, Apr 12 '18 at 15:10

score 0 · Answer 1 · answered Apr 12 '18 at 15:17

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

score 0 · Answer 2 · answered Apr 12 '18 at 15:19

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:

Macro for Intelligent Transpose

2 Answers2