Arrange set of data from vetical to horizontal by category

Thank you Yasser, this was very helpful.

I noticed that once the data are plotted on Column E, they are plotted by order of existence as available in range B.
Would it be possible to have them plotted by alphabetical order ?

Instead of having A,C,B,D,E
to have A,B,C,D,E, etc...

check the attached photoCapture.PNG

here is the workbook

Thank you

Try

Sub test()
    Dim x, y, i As Long, LastR As Long
    LastR = Range("b" & Rows.Count).End(xlUp).Row
    x = Filter(Evaluate("transpose(if(countif(offset(b3:b" & LastR & ",,,row(1:" & _
            LastR & ")),b3:b" & LastR & ")=1,b3:b" & LastR & "))"), False, 0)
    With [e2].Resize(, UBound(x) + 1)
        .Value = x
        For i = 1 To .Columns.Count
            y = Filter(Evaluate("transpose(if(b3:b" & LastR & "=" & _
                .Cells(1, i).Address & ",a3:a" & LastR & "))"), False, 0)
            .Cells(2, i).Resize(UBound(y) + 1).Value = Application.Transpose(y)
        Next
    End With
End Sub

Hello Jindon,

It is still not plotting them by alphabetical order. And it would be better to plot the data on the same sheet cell(1,8).

attached workbook if needed.

Originally Posted by jindon

Sub test()
    Dim a, b, i As Long, n As Long, maxRow As Long
    With Sheets("item category")
        a = .Range("a7", .Range("a" & Rows.Count).End(xlUp)).Resize(, 5).Value
    End With
    ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 100)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 5)) Then
                .Item(a(i, 5)) = Array(1, .Count + 1)
                If UBound(b, 2) < .Count Then
                    ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + 100)
                End If
                b(1, .Count) = a(i, 5)
            End If
            n = .Item(a(i, 5))(0) + 1
            b(n, .Item(a(i, 5))(1)) = a(i, 2)
            .Item(a(i, 5)) = Array(n, .Item(a(i, 5))(1))
            If maxRow < n Then maxRow = n
        Next
        ReDim Preserve b(1 To UBound(b, 1), 1 To .Count)
    End With
    With Sheets.Add.Cells(1).Resize(maxRow, UBound(b, 2))
        .Value = b
        .Columns.AutoFit
    End With
End Sub

Alphabetical order?

Private Sub CommandButton1_Click()

    Dim a, b, i As Long, n As Long, maxRow As Long
    a = Me.Range("a7", Me.Range("a" & Rows.Count).End(xlUp)).Resize(, 5).Value
    ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 100)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 5)) Then
                .Item(a(i, 5)) = Array(1, .Count + 1)
                If UBound(b, 2) < .Count Then
                    ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + 100)
                End If
                b(1, .Count) = a(i, 5)
            End If
            n = .Item(a(i, 5))(0) + 1
            b(n, .Item(a(i, 5))(1)) = a(i, 2)
            .Item(a(i, 5)) = Array(n, .Item(a(i, 5))(1))
            If maxRow < n Then maxRow = n
        Next
        ReDim Preserve b(1 To UBound(b, 1), 1 To .Count)
    End With
    With Me.[h6].Resize(maxRow, UBound(b, 2))
        .CurrentRegion.ClearContents
        .Value = b
        .Sort .Rows(1), 1, Orientation:=2
        .Columns.AutoFit
    End With

End Sub

yes if you check the below photo, the plotting in the new sheet starts with the first category, and not by alphabetical order (a,b,c,d,...)

check the photo:
Capture.PNG

Originally Posted by jindon

Alphabetical order?

Private Sub CommandButton1_Click()

    Dim a, b, i As Long, n As Long, maxRow As Long
    a = Me.Range("a7", Me.Range("a" & Rows.Count).End(xlUp)).Resize(, 5).Value
    ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 100)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 5)) Then
                .Item(a(i, 5)) = Array(1, .Count + 1)
                If UBound(b, 2) < .Count Then
                    ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + 100)
                End If
                b(1, .Count) = a(i, 5)
            End If
            n = .Item(a(i, 5))(0) + 1
            b(n, .Item(a(i, 5))(1)) = a(i, 2)
            .Item(a(i, 5)) = Array(n, .Item(a(i, 5))(1))
            If maxRow < n Then maxRow = n
        Next
        ReDim Preserve b(1 To UBound(b, 1), 1 To .Count)
    End With
    With Me.[h6].Resize(maxRow, UBound(b, 2))
        .CurrentRegion.ClearContents
        .Value = b
        .Sort .Rows(1), 1, Orientation:=2
        .Columns.AutoFit
    End With

End Sub

1)
Don't quote whole posts -- it's just clutter.
If you are responding to a post out of sequence, limit quoted content to a few relevant lines that makes clear to whom and what you are responding

For normal conversational replies, try using the QUICK REPLY box below.

2) Which one are you talking about?

Wonderful,

Thank you for the support, and also for the guidance. That is my second day here, good to know such guidelines.

Regards,

You are welcome and thanks for the rep.

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