Transposing multiple columns to rows based on unique values from first column

[mattc1985]

Dear all,

I need to transpose Columns B:N based on unique values in Column A to rows. I have already found a VBA script on this forum that acomplishes this to a degree:

It was posted in this thread: Transpose Unique Values in column to row
by user DanteAmor

Sub TransposeColumns()
  Dim a As Variant, b() As Variant
  Dim dic As Object, i As Long, lin As Long, col As Long, n As Long
  Dim lr As Long
  
  lr = ActiveSheet.Range("A:C").Find("*", , xlValues, , xlByRows, xlPrevious).Row
  Set dic = CreateObject("Scripting.Dictionary")
  a = Range("A2:C" & lr).Value2
  Range("D2", Cells(Rows.Count, Columns.Count)).ClearContents
  
  For i = 1 To UBound(a)
    dic(a(i, 1)) = dic(a(i, 1)) + 1
    If dic(a(i, 1)) > n Then n = dic(a(i, 1))
  Next
  n = (n * 2) + 1
  ReDim b(1 To dic.Count, 1 To n)
  dic.RemoveAll
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      lin = lin + 1
      col = 1
      b(lin, col) = a(i, 1)
    Else
      lin = Split(dic(a(i, 1)), "|")(0)
      col = Split(dic(a(i, 1)), "|")(1) + 2
    End If
    dic(a(i, 1)) = lin & "|" & col
    b(lin, col + 1) = a(i, 2)
    b(lin, col + 2) = a(i, 3)
  Next
  Application.ScreenUpdating = False
  Range("E2").Resize(dic.Count, n).Value = b
  Application.ScreenUpdating = True
End Sub

I would appreciate if someone would give me some guidance how to expand this script where you have more than three columns. Thank you. Your help is greatly appreciated.

 

[DanteAmor]

Hi @mattc1985
Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.

You could put a sample of your data (it can be generic data).

And how do you want the result?​

To give examples use XL2BB tool​

Look at the example of this post, the poster put examples of how the data is in his sheets and put 2 examples of the results he wants.

match based on headers and cell and sheet name to summing amounts

Hello I need populating sheets names in column A and I will write in cell C1 the month and headers B2:E2 across sheets so if I write month in C1 JAN , then should populate list of sheets names in column A and match headers and should sum the amounts for each sheet...

www.mrexcel.com

He was so precise in his examples that the macro worked first time.​

--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------​

 

[mattc1985]

Thank you very much for your prompt response. I followed your advice and install the plug in. Here are the minisheets:

Source:

CbC_report_wo faultcodes_SoW-Slovenia (2).xlsm
	A	B	C	D	E	F	G	H	I	J
1	Doc number	Name	Address	Type	Date of acquisition	Date of inspection	Date of final report	Art. number	EAN	Price
2	4408	Joel Black	Abbey road 10, London	MAC5IONIC 5762 223	21.03.2023	25.05.2023	06.06.2023	444111		10
3	4408	Joel Black	Abbey road 10, London	MAC5IONIC 5762 224	21.03.2023	25.05.2023	06.06.2023	555666		7
4	4408	Joel Black	Abbey road 10, London	MAC5IONIC 5762 225	21.03.2023	25.05.2023	06.06.2023	1011223255	4210201233350	91,42
5	4435	Samantha White	Tottenham street 126, London	ULTIMATEYTH 3788 149	17.08.2022	25.05.2023	19.06.2023	444111		6
6	4435	Samantha White	Tottenham street 126, London	ULTIMATEYTH 3788 150	17.08.2022	25.05.2023	19.06.2023	81738770	4210201245250	13,58
7	4443	Eugene Porto	Court road 55, York	P11 5666 2255	17.12.2022	25.05.2023	08.06.2023	444111		10
8	4443	Eugene Porto	Court road 55, York	P11 5666 2256	17.12.2022	25.05.2023	08.06.2023	81721844		13,95
9	4589	KOSTIANTYN LUKASHENKO	Leicester square 189, Dover	PRO88THE 3652 126	05.10.2022	31.05.2023	08.06.2023	444111		20
10	4589	KOSTIANTYN LUKASHENKO	Leicester square 189, Dover	PRO88THE 3652 127	05.10.2022	31.05.2023	08.06.2023	555666		8
11	4589	KOSTIANTYN LUKASHENKO	Leicester square 189, Dover	PRO88THE 3652 128	05.10.2022	31.05.2023	08.06.2023	81745646		21,58
12	4598	BIGBANG INVEST LLC	Summer palace circle 85D, Swanage	PILIPY9 5123 1040	28.05.2021	31.05.2023	08.06.2023	444111		5
13	4598	BIGBANG INVEST LLC	Summer palace circle 85D, Swanage	PILIPY9 5123 1041	28.05.2021	31.05.2023	08.06.2023	555666		4
14	4598	BIGBANG INVEST LLC	Summer palace circle 85D, Swanage	PILIPY9 5123 1042	28.05.2021	31.05.2023	08.06.2023	84477206		3,32
15	4598	BIGBANG INVEST LLC	Summer palace circle 85D, Swanage	PILIPY9 5123 1043	28.05.2021	31.05.2023	08.06.2023	81123554		6,24
Source

Result:

CbC_report_wo faultcodes_SoW-Slovenia (2).xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
1	Doc number	Name	Address	Type	Date of acquisition	Date of inspection	Date of final report	Art. number	EAN	Price	Art. number	EAN	Price	Art. number	EAN	Price	Art. number	EAN	Price
2	4408	Joel Black	Abbey road 10, London	MAC5IONIC 5762 223	21.03.2023	25.05.2023	06.06.2023	444111		10	555666		7	1011223255	4210201233350	91,42
3	4435	Samantha White	Tottenham street 126, London	ULTIMATEYTH 3788 149	17.08.2022	25.05.2023	19.06.2023	444111		6	81738770	4210201245250	13,58
4	4443	Eugene Porto	Court road 55, York	P11 5666 2255	17.12.2022	25.05.2023	08.06.2023	444111		10	81721844		13,95
5	4589	KOSTIANTYN LUKASHENKO	Leicester square 189, Dover	PRO88THE 3652 126	05.10.2022	31.05.2023	08.06.2023	444111		20	555666		8	81745646		21,58
6	4598	BIGBANG INVEST LLC	Summer palace circle 85D, Swanage	PILIPY9 5123 1040	28.05.2021	31.05.2023	08.06.2023	444111		5	555666		4	84477206		3,32	81123554		6,24
Results

So, basically I would like to transpose H,I,J columns in Source to columns H,I,J,K,L,M,N,O,PQ,R,S in Results based on unique number in column A in Source sheet. I hope I managed to explain it properly Thank you for your input.

 

[DanteAmor]

Thanks for the example, now it is very clear to me.

Try the following macro:

Sub Transposing_multiple_columns()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim dic As Object
  Dim a As Variant, b As Variant
  Dim i&, j&, k&, y&, nMax&, nRow&, nCol&
 
  Set sh1 = Sheets("Source")
  Set sh2 = Sheets("Results")
  Set dic = CreateObject("Scripting.Dictionary")
 
  a = sh1.Range("A1:J" & sh1.Range("A" & Rows.Count).End(3).Row).Value
  For i = 2 To UBound(a, 1)
    dic(a(i, 1)) = dic(a(i, 1)) + 1
    If dic(a(i, 1)) > nMax Then nMax = dic(a(i, 1))
  Next
  ReDim b(1 To dic.Count + 1, 1 To 7 + (nMax * 3))
  dic.RemoveAll
 
  For j = 1 To 7
    b(1, j) = a(1, j)
  Next
  k = 8
  For i = 1 To nMax
    b(1, k) = a(1, 8)
    b(1, k + 1) = a(1, 9)
    b(1, k + 2) = a(1, 10)
    k = k + 3
  Next
  y = 1
  For i = 2 To UBound(a, 1)
    If Not dic.exists(a(i, 1)) Then
      y = y + 1
      dic(a(i, 1)) = y & "|" & 8
      For j = 1 To 7
        b(y, j) = a(i, j)
      Next
    End If
    nRow = Split(dic(a(i, 1)), "|")(0)
    nCol = Split(dic(a(i, 1)), "|")(1)
    b(nRow, nCol) = a(i, 8)
    b(nRow, nCol + 1) = a(i, 9)
    b(nRow, nCol + 2) = a(i, 10)
    dic(a(i, 1)) = nRow & "|" & nCol + 3
  Next
 
  sh2.Cells.ClearContents
  sh2.Range("A1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

 

[mattc1985]

Amazing! It works exactly as expected. Thank you very much sir!