Transpose Data Using Macro

Hi,


I am at a loss for how to do this. I attached a example of the data I'm trying to transpose. I have the current data on the left and pasted the result I'm going for on the right.

Thanks,

Jim

Try the attached

Sub test()
    Dim r As Range, i As Long, x As String
    Application.ScreenUpdating = False
    With Cells(1).CurrentRegion.Resize(, 3).Columns(1)
        .Offset(, 4).Resize(, 2).Clear
        For Each r In .SpecialCells(2)
            r(1, 2).Resize(, 2).Copy r.Offset(, 4)
        Next
        For Each r In .SpecialCells(4).Areas
            For i = 1 To 2
                x = r(0).Offset(, i).Resize(r.Count + 1).Address
                r(0, 4 + i).Value = Join(Filter(Evaluate("transpose(if(" & _
                        x & "<>""""," & x & ",char(2)))"), Chr(2), 0), ",")
            Next
        Next
    End With
    Application.ScreenUpdating = True
End Sub

Thanks Jindon,

Quick question...my orginal sheet is much longer. What do I edit to extend the Macro further down the sheet?

Just try the code with your original data and see what happens.

nevermind...I had a open cell in column A and it stopped. Works perfect!

Thanks!

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED.

Jindon,

I have one more question. Can there be something added to the script to skip over blank rows? The script stops when it hit a black row.

Thanks again,

Jim

Try change

    With Cells(1).CurrentRegion.Resize(, 3).Columns(1)

to

    With ActiveSheet.UsedRange.Columns(1)

If it doesn't work, I need to see your workbook again...

good to go!

Happy Holidays!