Transpose data from columns to rows

[harzer]

Hello everyone,
In a sheet named "Anc_Communs", I have three columns: "A", "B" and "C".
1- To begin, we will create a list with unique values from column "A" to column "E". I found a code to do this step, it's working.
2- Next, we will transpose the data from column “B” and column “C” for each cell in column “E”.
Here are the steps to do, for this, I will take an example to better explain to you
We work with the cells of column "E2", we take the value of the first cell of this column: "E2", we find the value of this cell in cells "A2" and "A3", we will therefore transpose the value of cell "B2" into "F2" and the value of "C2" into "G2", then, we transpose the value of cell "B3" into "H2" and the value of "C3" into "I2 "
We then move to the next cell of column "E", this is cell "E3", ", we find the value of this cell in cells "A4" and "A5", we will therefore transpose the value of cell "B4" to "F3" and the value of "C4" to "G3", then we transpose the value of cell "B5" to "H3" and the value of "C5" to "I3" .
Then we continue to do the same thing for all the cells in column “E”.
I started to do this part of code but I'm stuck and I can't move forward, I used tables to make the code faster), I'm putting it at your disposal in the hope that an expert in vba any of you could help me finalize.
Thank you in advance for your contributions.

Starting table:

compare colonnes.xlsm
	A	B	C
1	Sujets	Réf	Nombre
2	A	O	1
3	A	M	2
4	B	VV	3
5	B	TT	4
6	C	HHH	5
7	C	XXX	6
8	C	WWW	7
9	D	TTTT	8
10	D	JJJJ	9
11	D	IIII	10
12	D	NNNN	11
13	D	MMMM	12
14	E	LLLLL	13
15	E	FFFFF	14
16	E	UUUUU	15
17	E	JJJJJ	16
18	E	BBBBB	17
19	E	QQQQQ	18
20	F	CCCCCC	19
21	G	GGGGGG	20
22	G	YYYYYY	21
23	G	PPPPPP	22
24	G	SSSSSS	23
25	G	ZZZZZZ	24
Anc_Communs

Unless I'm mistaken, here is the final result:

Exporter.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1	Sujets	Réf	Nombre		Sujets
2	A	O	1		A	O	1	M	2
3	A	M	2		B	VV	3	TT	4
4	B	VV	3		C	HHH	5	XXX	6	WWW	7
5	B	TT	4		D	TTTT	8	JJJJ	9	IIII	10	NNNN	11	MMMM	12
6	C	HHH	5		E	LLLLL	13	FFFFF	14	UUUUU	15	JJJJJ	16	BBBBB	17	QQQQQ	18
7	C	XXX	6		F	CCCCCC	19
8	C	WWW	7		G	GGGGGG	20	YYYYYY	21	PPPPPP	22	SSSSSS	23	ZZZZZZ	24
9	D	TTTT	8
10	D	JJJJ	9
11	D	IIII	10
12	D	NNNN	11
13	D	MMMM	12
14	E	LLLLL	13
15	E	FFFFF	14
16	E	UUUUU	15
17	E	JJJJJ	16
18	E	BBBBB	17
19	E	QQQQQ	18
20	F	CCCCCC	19
21	G	GGGGGG	20
22	G	YYYYYY	21
23	G	PPPPPP	22
24	G	SSSSSS	23
25	G	ZZZZZZ	24
Anc_Communs

Here is the code I tried to do:

Sub Transpose()

'''''############ Create a list without duplicates from column "A" to column "E" ############''''''''

Dim a As Variant, itm As Variant
  Dim d As Object
 
  Set d = CreateObject("Scripting.Dictionary")
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  For Each itm In a
    d(itm) = Empty
  Next itm
  Range("E2").Resize(d.Count).Value = Application.Transpose(d.Keys)
 
'''''###########################################################################################################''''''''

'''''############ Code to transpose data from column "B" and "C" into rows based on values from column "E" ############''''''''

    Dim Ws As Worksheet
    Dim rng_E As Range, rng_A As Range
    Dim LRow_E As Long, LRow_A As Long
    Dim i As Long, j As Long, n As Long
    Dim Array_E, Array_A, TempAr() As String
    Dim boolFound As Boolean

    Set Ws = ThisWorkbook.Sheets("Anc_Communs")

    LRow_E = Ws.Cells(Rows.Count, "E").End(xlUp).Row
    LRow_A = Ws.Cells(Rows.Count, "A").End(xlUp).Row

    Set rng_E = Ws.Range("E2:E" & LRow_E)
    Set rng_A = Ws.Range("A2:A" & LRow_A)

    Array_E = rng_E.Value
    Array_A = rng_A.Value

    For i = LBound(Array_E) To UBound(Array_E)
        For j = LBound(Array_A) To UBound(Array_A)
            If Array_E(i, 1) = Array_A(j, 1) Then
                boolFound = False
                Exit For
            End If
        Next j

        If boolFound = True Then
            ReDim Preserve TempAr(n)
            TempAr(n) = Array_A(i, 1)
            n = n + 1
        Else
            boolFound = False
        End If
    Next i
   
    m = 2
      Ws.Cells(m + 1, 6).Resize(UBound(TempAr) + 1, 6).Value = Application.Transpose(TempAr)
'    Ws.Cells(LRow_E + 1, 1).Resize(UBound(TempAr) + 1, 1).Value = Application.Transpose(TempAr)
 
'''''###########################################################################################################''''''''

End Sub

 

[harzer]

Hello again,
Please use tables (LBound & UBound) because the data to be processed is very numerous, as proof, the loop will process 50000 cells.

 

[alansidman]

Using a combination of Power Query and Power Pivot, I achieved the following.

Book9
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
2	A	O	1			1		2		3		4		5		6
3	A	M	2		Row Labels	CRef	CNom	CRef	CNom	CRef	CNom	CRef	CNom	CRef	CNom	CRef	CNom
4	B	VV	3		A	O	1	M	2
5	B	TT	4		B	VV	3	TT	4
6	C	HHH	5		C	HHH	5	XXX	6	WWW	7
7	C	XXX	6		D	TTTT	8	JJJJ	9	IIII	10	NNNN	11	MMMM	12
8	C	WWW	7		E	LLLLL	13	FFFFF	14	UUUUU	15	JJJJJ	16	BBBBB	17	QQQQQ	18
9	D	TTTT	8		F	CCCCCC	19
10	D	JJJJ	9		G	GGGGGG	20	YYYYYY	21	PPPPPP	22	SSSSSS	23	ZZZZZZ	24
11	D	IIII	10
12	D	NNNN	11
13	D	MMMM	12
14	E	LLLLL	13
15	E	FFFFF	14
16	E	UUUUU	15
17	E	JJJJJ	16
18	E	BBBBB	17
19	E	QQQQQ	18
20	F	CCCCCC	19
21	G	GGGGGG	20
22	G	YYYYYY	21
23	G	PPPPPP	22
24	G	SSSSSS	23
25	G	ZZZZZZ	24
Sheet1

Here is the Mcode for Power Query and the results are then closed to the Data Model so that the data can be pivoted in Power Pivot

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Grouped Rows" = Table.Group(Source, {"Sujets"}, {{"Count", each _, type table [Sujets=text, Réf=text, Nombre=number]}}),
    #"Added Custom" = Table.AddColumn(#"Grouped Rows", "Custom", each Table.AddIndexColumn([Count],"Index",1,1)),
    #"Removed Columns" = Table.RemoveColumns(#"Added Custom",{"Count"}),
    #"Expanded Custom" = Table.ExpandTableColumn(#"Removed Columns", "Custom", {"Réf", "Nombre", "Index"}, {"Réf", "Nombre", "Index"})
in
    #"Expanded Custom"

In Power Pivot, two measures are created

=CONCATENATEX(Table1,Table1[Réf],", ")

=CONCATENATEX(Table1,Table1[Nombre],", ")

 

[NateSC]

alansidman beat me to a solution, but here is the straight VBA method so you have a second option. I'm not sure which method is faster.

Replace the code from where you set the rng_A and below.
I got rid of the Boolean test and the output array needs to be a 2D array instead of 1D. Then you just output the array in the end instead of using the transpose function.
This works for Base 0 and would need updates if you use Base 1.

'CHANGED TO PULL ALL 3 COLUMNS OF DATA - ALL MODS BELOW HERE
    
    Set rng_A = Ws.Range("A2:C" & LRow_A)

    Array_E = rng_E.Value
    Array_A = rng_A.Value

    Dim myTop As Integer
    Dim nMax As Integer
    myTop = UBound(Array_E) - 1
    'The TempAr will have as many rows as Array_E, but will have to figure out the columns as it processes -
    'Note: you can only change the second index in an array with the Redim statement. 
    'Luckily we know the first index will be the same as the UBound of Array_E
    ReDim TempAr(myTop, 0)
    n = 0
    nMax = -1

    For i = LBound(Array_E) To UBound(Array_E)
        For j = LBound(Array_A) To UBound(Array_A)
            If Array_E(i, 1) = Array_A(j, 1) Then
                'Only redim the array if needed because n will exceed nMax
                If n > nMax Then
                    nMax = n + 1
                    ReDim Preserve TempAr(myTop, nMax)
                End If
                'Copy the data to the TempAr for column B and C of the row you are working on
                TempAr(i - 1, n) = Array_A(j, 2)
                TempAr(i - 1, n + 1) = Array_A(j, 3)
                n = n + 2
            Else
                n = 0
            End If
        Next j

    Next i
   
    m = 1
    Ws.Cells(m + 1, 6).Resize(UBound(TempAr) + 1, nMax + 1).Value = TempAr

 

[harzer]

Hello Alansidman,
Thank you for your response, but unfortunately I have never used Power Query and I don't know how I should implement your work, my programming level is limited, sorry.
Did you create a sheet that you worked on, if so, how can we get it back?
Maybe put it online and let me grab it with a download link!
Or by private message, as long as the forum rules allow it!
Thank you in any case for your response and the work provided.
While waiting for your return, I will retrieve the NateSC code to test it.
Greetings.

 

[alansidman]

Here is a link to the file located in Box.Net

PQ-PP.xlsx | Powered by Box

app.box.com

...and be sure to check out the link for PQ in my signature block.

 

[harzer]

Hello NateSC and Alansidman,
I'm contacting NateSC to say thank you for the feedback and the proposed code.
I tested your code, I am completely satisfied because the code meets my expectations and gives me the desired result.
Big thanks.

Now I'm reaching out to alansidman to say thanks for the link, I'm going to download the file to start my testing.
Greetings and see you soon after the tests.

 

[harzer]

Hello Alansidman & NateSC,
Thanks for the attachment.
I tested your work and I can assure you that the sheet with Power Query works well.
I noticed that I have to refresh the table when there is new data.
Thank you very much for a job well done.
I now have two solutions, yours and NateSC's.
Thank you both.
Greetings.