VBA - trying to extract data and show it in two dimension

[LBee]

Hi all

I'm trying to create at macro, that makes data more readable by creating a two-dimensional view, but I'm so stuck.
Using data from examples found on differeny webpages, I mange to either have data from column a in rows or data from column B in columns, but I have no idea how to combine those

I have made a simple example, to illustrate what data looks like, and what my goal is

Data looks like this

Customer	Product
Customer1	a
Customer1	c
Customer2	a
Customer2	d
Customer2	e
Customer2	f
Customer3	a
Customer3	b
Customer3	c
Customer3	d
Customer3	e
Customer4	a
Customer4	e

And my goal is to create a new sheet looking like this :

Customer1	a	c
Customer2	a	d	e	f
Customer3	a	b	c	d	e
Customer4	a	e

Does it make sense and if yes, is it even possible to do what I'm trying to do?

 

[KOKOSEK]

I do not know how big bunch of data you are dealing with, but maybe you can use formulas instead of macro:

Book1
	A	B	C	D	E	F	G	H	I
1	Customer	Product
2	Customer1	a		Customer1	a	c
3	Customer1	c		Customer2	a	d	e	f
4	Customer2	a		Customer3	a	b	c	d	e
5	Customer2	d		Customer4	a	e
6	Customer2	e
7	Customer2	f
8	Customer3	a
9	Customer3	b
10	Customer3	c
11	Customer3	d
12	Customer3	e
13	Customer4	a
14	Customer4	e
Sheet1

Cell Formulas
Range	Formula
D2:D5	D2	=UNIQUE($A$2:$A$14)
E2:F2,E5:F5,E4:I4,E3:H3	E2	=TRANSPOSE(FILTER($B$2:$B$14,$A$2:$A$14=$D2))
Dynamic array formulas.

 

[mohadin]

Hi

I'm trying to create at macro

Try

Sub test()
    Dim a
    Dim i&
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    a = Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row).Resize(, 2)
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If a(i, 1) <> 0 Then
                If Not .exists(a(i, 1)) Then
                    .Add a(i, 1), a(i, 2)
                Else
                    .Item(a(i, 1)) = .Item(a(i, 1)) & "," & a(i, 2)
                End If
            End If
        Next
        a = Application.Index(Array(.keys, .items), 0, 0)
        Cells(2, 4).Resize(.Count, 2) = Application.Transpose(a)
        Columns("E:E").TextToColumns Destination:=Range("E1"), Comma:=True, FieldInfo:=Array(Array(1, 1))
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

[LBee]

Thanks a lot for the answersm, both of you.
The amount of data could get relatively big, and if it was possible, I would prefer to do it with a macro (which it apparently was ), but I always love to see different approaches to the same problem.

I can confirm that the macro is working, but I also now realise that if forgot to mention, that my goal was to have the output in a separate sheet, which would have been easier to see if I had used xl2bb table instead of using mini sheet (learning a lot today) .

Would it be possible to send the output a sepereate sheet instead?

 

[mohadin]

that my goal was to have the output in a separate sheet

Then try

Sub test()
    Dim a
    Dim i&
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Sheets("sheet1") '<< Change  source sheet name as requiered
    a = .Range("a2:a" & .Cells(Rows.Count, 1).End(xlUp).Row).Resize(, 2)
    End With
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If a(i, 1) <> 0 Then
                If Not .exists(a(i, 1)) Then
                    .Add a(i, 1), a(i, 2)
                Else
                    .Item(a(i, 1)) = .Item(a(i, 1)) & "," & a(i, 2)
                End If
            End If
        Next
        a = Application.Index(Array(.keys, .items), 0, 0)
        End With
        With Sheets("sheet2") '<< Change  Destination sheet name as requiered
        .Cells(2, 1).Resize(UBound(a, 2), 2) = Application.Transpose(a)
        .Columns("B:B").TextToColumns Destination:=.Range("B1"), Comma:=True, FieldInfo:=Array(Array(1, 1))
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

[LBee]

Hi mohadin

I can confirm it working (with a minor adjustment)
In this line I had to replace B1 with B2, otherwise the output was messing up a bit (but that was an easy fix)

.Columns("B:B").TextToColumns Destination:=.Range("B1"), Comma:=True, FieldInfo:=Array(Array(1, 1))

Now I need to dig in was the "CreateObject("scripting.dictionary")" part actually does, I guess thats where the magic happens

Thanks a lot for you help

 

[mohadin]

You are very welcome LBee
Glad I could help
Thank you for the feedback
Be happy and safe