transform from vertical to horizontal

[YasserKhalil]

Hello everyone
I have range("A2:B7") in vertical form based on ID in first column and I need to transform the data to horizontal form using formulas if possible
I have attached a sample workbook

Thanks advanced for help

[HansV]

Here is a macro:

Code: Select all

Sub Transform()
    Dim s As Long
    Dim m As Long
    Dim t As Long
    Dim c As Long
    Application.ScreenUpdating = False
    t = 1
    Cells(1, 1).CurrentRegion.Sort Key1:=Cells(1, 1), Header:=xlYes
    m = Cells(1, 1).End(xlDown).Row
    For s = 2 To m
        If Cells(s, 1).Value <> Cells(s - 1, 1).Value Then
            t = t + 1
            Cells(t, 5).Value = Cells(s, 1).Value
            c = 5
        End If
        c = c + 1
        Cells(t, c).Value = Cells(s, 2).Value
    Next s
    Application.ScreenUpdating = True
End Sub

[YasserKhalil]

Excellent solution. Thanks a lot for that wonderful help
But I noticed that data in column A & B are sorted and I want these columns not to be touched if possible
Best Regards

[YasserKhalil]

This code do the trick

Code: Select all

Sub Test()
    Dim i As Long
    Dim arr, e

    With ActiveSheet
        arr = .Range("A1").CurrentRegion
    End With

    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(arr)
            If Not .exists(arr(i, 1)) Then
                .Item(arr(i, 1)) = arr(i, 2)
            Else
                .Item(arr(i, 1)) = Join(Array(.Item(arr(i, 1)), arr(i, 2)), ", ")
            End If
        Next i
        
        i = 1
        For Each e In .keys
            Cells(i, 7) = e
            Cells(i, 8) = .Item(e)
            i = i + 1
        Next
    End With
End Sub

But I don't to collect the results in one cell. I need results to be in different columns

[HansV]

You could use TextToColumns to split the date:

Code: Select all

Sub Test()
    Dim i As Long
    Dim arr, e

    With ActiveSheet
        arr = .Range("A1").CurrentRegion
    End With

    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(arr)
            If Not .exists(arr(i, 1)) Then
                .Item(arr(i, 1)) = arr(i, 2)
            Else
                .Item(arr(i, 1)) = Join(Array(.Item(arr(i, 1)), arr(i, 2)), ",")
            End If
        Next i
        
        i = 1
        For Each e In .keys
            Cells(i, 7) = e
            Cells(i, 8) = .Item(e)
            i = i + 1
        Next
    End With

    Range(Cells(2, 8), Cells(2, 8).End(xlDown)).TextToColumns Comma:=True
End Sub

[YasserKhalil]

I tried to edit this line but got incorrect results

Code: Select all

Cells(i, 8).Resize(, UBound(.keys)).Value = Split(.Item(e), ", ")

[YasserKhalil]

Can this be done using formulas Mr. Hans?

[HansV]

Probably, but the formulas would be too complicated for me.

[YasserKhalil]

Thanks a lot for reply Mr. Hans

[Toranaga]

Can this be done using formulas Mr. Hans?

In column E for Unic ID:

E2 =INDEX($A$2:$A$10, MATCH(0, COUNTIF($E1:E$1,$A$2:$A$10& ""), 0)) this is array formula (Ctrl+Shift+Enter)

and normal formula, in F2:

=IFERROR(INDEX($B$2:$B$8,AGGREGATE(15,6,(ROW($A$2:$A$8)-ROW($A$2)+1)/($A$2:$A$8=$E2),COLUMNS($F2:F2))),"")

then drag down and to right.

[YasserKhalil]

Thanks a lot for this wonderful solution Mr. Toranaga
Really wonderful

[Toranaga]

YasserKhalil,

You now the rules forums. It would have been nice of you to say you've posted on other forums, the same question and post the URL to that site.

http://www.vbaexpress.com/forum/showthr ... horizontal

[YasserKhalil]

I am so sorry
I forgot at all to post the link .. I usually put the links to the threads
Sorry about that
Regards