VBA Help: Transpose data from duplicate rows to Multiple new columns

[MattGS]

Hi, I have seen various formulas to do this but they only work with 1 column of Data. where there is a duplicate in Column A, take cells in columns D:G add them to the line above and delete Line, so I only end up with 1 Row and transposed data:

SearchResults.xlsm
	A	B	C	D	E	F	G
1	Part Number	Description	Footprint/Page Size	Preferred Status (Manufacturers)	Mfr. Part Lifecycle Phase (Manufacturers)	Mfr. Name (Manufacturers)	Mfr. Part Number (Manufacturers)
2	3513-999-55580	CAP 6N8 16V 2% ( 0805 )	0805	Preferred	Manufacturer Parts.Active	Panasonic	ECHU1C6N8GX5
3	3513-999-55583	CAP 68N 16V 5%	1210	Preferred	Manufacturer Parts.Active	Panasonic	ECHU1C683JX5
4	3513-999-55584	CAP 10N 16V 5%	1210	Preferred	Manufacturer Parts.Active	Panasonic	ECHU1C103JX5
5	3513-999-55585	CAP 3N3 16V 5%	0805	Preferred	Manufacturer Parts.Active	Panasonic	ECHU1C332JX5
6	3513-999-60009	CAP 3N9 2% PL FLM 16V	0805	Preferred	Manufacturer Parts.Active	Panasonic	ECHU1C392GX5
7	3513-999-60105	CAP 1p ±0p25 C 50V C0G ( 0402 )	0402	Preferred	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H1R0CA01[]
8	3513-999-60105	CAP 1p ±0p25 C 50V C0G ( 0402 )	0402	Alternate	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H1R0BA01[]
9	3513-999-60105	CAP 1p ±0p25 C 50V C0G ( 0402 )	0402	Alternate	Manufacturer Parts.Obsolete	Samsung Electro-Mechanics GmbH	CL05C010BB5NNNC
10	3513-999-60105	CAP 1p ±0p25 C 50V C0G ( 0402 )	0402	Alternate	Manufacturer Parts.Active	AVX Kyocera	04025A1R0BAT2A
11	3513-999-60105	CAP 1p ±0p25 C 50V C0G ( 0402 )	0402	Alternate	Manufacturer Parts.Active	Murata Electronics UK Ltd	GCM1555C1H1R0BA16[]
12	3513-999-60105	CAP 1p ±0p25 C 50V C0G ( 0402 )	0402	Alternate	Manufacturer Parts.Active	Murata Electronics UK Ltd	GJM1555C1H1R0BB01[]
13	3513-999-60106	CAP 1p2 ±0p25 50V C0G ( 0402 )	0402	Preferred	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H1R2CA01[]
14	3513-999-60106	CAP 1p2 ±0p25 50V C0G ( 0402 )	0402	Alternate	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H1R2BA01[]
15	3513-999-60106	CAP 1p2 ±0p25 50V C0G ( 0402 )	0402	Alternate	Manufacturer Parts.Obsolete	Samsung Electro-Mechanics GmbH	CL05C1R2BB5NNNC
16	3513-999-60106	CAP 1p2 ±0p25 50V C0G ( 0402 )	0402	Alternate	Manufacturer Parts.Active	AVX Kyocera	04025A1R2BAT2A
17	3513-999-60106	CAP 1p2 ±0p25 50V C0G ( 0402 )	0402	Alternate	Manufacturer Parts.Active	Murata Electronics UK Ltd	GJM1555C1H1R2BB01[]
18	3513-999-60106	CAP 1p2 ±0p25 50V C0G ( 0402 )	0402	Alternate	Manufacturer Parts.Active	Murata Electronics UK Ltd	GCM1555C1H1R2BA16[]
19	3513-999-60107	CAP 1p5 ±0p25 C 50V C0G ( 0402 )	0402	Preferred	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H1R5CA01[]
20	3513-999-60107	CAP 1p5 ±0p25 C 50V C0G ( 0402 )	0402	Alternate	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H1R5BA01-[]
21	3513-999-60107	CAP 1p5 ±0p25 C 50V C0G ( 0402 )	0402	Alternate	Manufacturer Parts.Active	Samsung Electro-Mechanics GmbH	CL05C1R5BB5NNNC
22	3513-999-60107	CAP 1p5 ±0p25 C 50V C0G ( 0402 )	0402	Alternate	Manufacturer Parts.Active	AVX Kyocera	04025A1R5BAT2A
23	3513-999-60107	CAP 1p5 ±0p25 C 50V C0G ( 0402 )	0402	Alternate	Manufacturer Parts.Active	Murata Electronics UK Ltd	GJM1555C1H1R5BB01[]
24	3513-999-60107	CAP 1p5 ±0p25 C 50V C0G ( 0402 )	0402	Alternate	Manufacturer Parts.Active	Murata Electronics UK Ltd	GCM1555C1H1R5BA16[]
25	3513-999-60108	CAP 1p8 ±0p25 50V C0G ( 0402 )	0402	Preferred	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H1R8CA01[]
26	3513-999-60108	CAP 1p8 ±0p25 50V C0G ( 0402 )	0402	Alternate	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H1R8BA01[]
27	3513-999-60108	CAP 1p8 ±0p25 50V C0G ( 0402 )	0402	Alternate	Manufacturer Parts.Active	Murata Electronics UK Ltd	GCM1555C1H1R8BA16[]
28	3513-999-60108	CAP 1p8 ±0p25 50V C0G ( 0402 )	0402	Alternate	Manufacturer Parts.Active	Murata Electronics UK Ltd	GJM1555C1H1R8BB01[]
29	3513-999-60108	CAP 1p8 ±0p25 50V C0G ( 0402 )	0402	Alternate	Manufacturer Parts.Active	AVX Kyocera	04025A1R8BAT2A
30	3513-999-60108	CAP 1p8 ±0p25 50V C0G ( 0402 )	0402	Alternate	Manufacturer Parts.Obsolete	Samsung Electro-Mechanics GmbH	CL05C1R8BB5NNN[]
31	3513-999-60109	CAP 2p2 ±0p25 50V C0G ( 0402 )	0402	Preferred	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H2R2CA01[]
Sheet0

So would end up with something like:

SearchResults-7.xls
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W
1	Part Number	Description	Product Line(s)	Footprint/Page Size	Preferred Status (Manufacturers)	Mfr. Name (Manufacturers)	Mfr. Part Number (Manufacturers)	Mfr. Part Lifecycle Phase (Manufacturers)	Mfr. Name (Manufacturers)	Mfr. Part Number (Manufacturers)	Mfr. Part Lifecycle Phase (Manufacturers)	Mfr. Name (Manufacturers)	Mfr. Part Number (Manufacturers)	Mfr. Part Lifecycle Phase (Manufacturers)	Mfr. Name (Manufacturers)	Mfr. Part Number (Manufacturers)	Mfr. Part Lifecycle Phase (Manufacturers)	Mfr. Name (Manufacturers)	Mfr. Part Number (Manufacturers)	Mfr. Part Lifecycle Phase (Manufacturers)	Mfr. Name (Manufacturers)	Mfr. Part Number (Manufacturers)	Mfr. Part Lifecycle Phase (Manufacturers)
2	3513-999-55580	CAP 6N8 16V 2% ( 0805 )	Various/Misc	0805	Preferred	Panasonic	ECHU1C6N8GX5	Manufacturer Parts.Active
3	3513-999-55583	CAP 68N 16V 5%	Various/Misc	1210	Preferred	Panasonic	ECHU1C683JX5	Manufacturer Parts.Active
4	3513-999-55584	CAP 10N 16V 5%	Various/Misc	1210	Preferred	Panasonic	ECHU1C103JX5	Manufacturer Parts.Active
5	3513-999-55585	CAP 3N3 16V 5%	Various/Misc	0805	Preferred	Panasonic	ECHU1C332JX5	Manufacturer Parts.Active
6	3513-999-60009	CAP 3N9 2% PL FLM 16V	Various/Misc	0805	Preferred	Panasonic	ECHU1C392GX5	Manufacturer Parts.Active
7	3513-999-60105	CAP 1p ±0p25 C 50V C0G ( 0402 )	Various/Misc	0402	Preferred	Murata Electronics UK Ltd	GRM1555C1H1R0CA01[]	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H1R0BA01[]	Manufacturer parts.Active - Not Recommended for New Designs	Samsung Electro-Mechanics GmbH	CL05C010BB5NNNC	Manufacturer Parts.Obsolete	AVX Kyocera	04025A1R0BAT2A	Manufacturer Parts.Active	Murata Electronics UK Ltd	GCM1555C1H1R0BA16[]	Manufacturer Parts.Active	Murata Electronics UK Ltd	GJM1555C1H1R0BB01[]	Manufacturer Parts.Active
8	3513-999-60106	CAP 1p2 ±0p25 50V C0G ( 0402 )	Various/Misc	0402	Preferred	Murata Electronics UK Ltd	GRM1555C1H1R2CA01[]	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H1R2BA01[]	Manufacturer parts.Active - Not Recommended for New Designs	Samsung Electro-Mechanics GmbH	CL05C1R2BB5NNNC	Manufacturer Parts.Obsolete	AVX Kyocera	04025A1R2BAT2A	Manufacturer Parts.Active	Murata Electronics UK Ltd	GJM1555C1H1R2BB01[]	Manufacturer Parts.Active	Murata Electronics UK Ltd	GCM1555C1H1R2BA16[]	Manufacturer Parts.Active
9	3513-999-60107	CAP 1p5 ±0p25 C 50V C0G ( 0402 )	Various/Misc	0402	Preferred	Murata Electronics UK Ltd	GRM1555C1H1R5CA01[]	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H1R5BA01-[]	Manufacturer parts.Active - Not Recommended for New Designs	Samsung Electro-Mechanics GmbH	CL05C1R5BB5NNNC	Manufacturer Parts.Active	AVX Kyocera	04025A1R5BAT2A	Manufacturer Parts.Active	Murata Electronics UK Ltd	GJM1555C1H1R5BB01[]	Manufacturer Parts.Active	Murata Electronics UK Ltd	GCM1555C1H1R5BA16[]	Manufacturer Parts.Active
Sheet0

 

[mumps]

Change the sheet names (in red) to suit your needs.

Sub TransposeData2()
    Application.ScreenUpdating = False
    Dim lRow As Long, i As Long, rCount As Long, dic As Object, v As Variant, srcWS As Worksheet, desWS As Worksheet, rng As Range
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 7).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v) To UBound(v)
        If Not dic.exists(v(i, 1)) Then
            dic.Add v(i, 1), Nothing
            With srcWS.Cells(1).CurrentRegion
                .AutoFilter 1, v(i, 1)
                rCount = srcWS.[subtotal(103,A:A)] - 1
                If rCount = 1 Then
                    desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 5).Value = Array(v(i, 1), v(i, 2), "Various/Misc", v(i, 3), v(i, 4))
                Else
                    With desWS
                        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                        .Range("A" & lRow).Resize(, 5).Value = Array(v(i, 1), v(i, 2), "Various/Misc", v(i, 3), v(i, 4))
                        For Each rng In srcWS.Range("F2", srcWS.Range("F" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
                            .Cells(lRow, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(, 3).Value = Array(rng, rng.Offset(, 1), rng.Offset(, -1))
                        Next rng
                    End With
                End If
            End With
        End If
    Next i
    desWS.Columns.AutoFit
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[MattGS]

Hi Mumps,

thank you for the code was extremly useful, Apologies, i made an error in the output it shoud be the Product Lines column should not havbe been in output: it also eems to remove all the information for single source items, so as example 3513-999-55580 has no manufacturer information, you can see in current output file:

SearchResults.xlsm
	A	B	C	D	E	F	G
1	Part Number	Description	Footprint/Page Size	Preferred Status (Manufacturers)	Mfr. Part Lifecycle Phase (Manufacturers)	Mfr. Name (Manufacturers)	Mfr. Part Number (Manufacturers)
2	3513-999-55580	CAP 6N8 16V 2% ( 0805 )	Various/Misc	Preferred	Preferred
Sheet1

so the output sheet should look like:

SearchResults-7.xls
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V
1	Part Number	Description	Footprint/Page Size	Preferred Status (Manufacturers)	Mfr. Part Lifecycle Phase (Manufacturers)	Mfr. Name (Manufacturers)	Mfr. Part Number (Manufacturers)	Mfr. Part Lifecycle Phase (Manufacturers)	Mfr. Name (Manufacturers)	Mfr. Part Number (Manufacturers)	Mfr. Part Lifecycle Phase (Manufacturers)	Mfr. Name (Manufacturers)	Mfr. Part Number (Manufacturers)	Mfr. Part Lifecycle Phase (Manufacturers)	Mfr. Name (Manufacturers)	Mfr. Part Number (Manufacturers)	Mfr. Part Lifecycle Phase (Manufacturers)	Mfr. Name (Manufacturers)	Mfr. Part Number (Manufacturers)	Mfr. Part Lifecycle Phase (Manufacturers)	Mfr. Name (Manufacturers)	Mfr. Part Number (Manufacturers)
2	3513-999-55580	CAP 6N8 16V 2% ( 0805 )	0805	Preferred	Manufacturer Parts.Active	Panasonic	ECHU1C6N8GX5
3	3513-999-55583	CAP 68N 16V 5%	1210	Preferred	Manufacturer Parts.Active	Panasonic	ECHU1C683JX5
4	3513-999-55584	CAP 10N 16V 5%	1210	Preferred	Manufacturer Parts.Active	Panasonic	ECHU1C103JX5
5	3513-999-55585	CAP 3N3 16V 5%	0805	Preferred	Manufacturer Parts.Active	Panasonic	ECHU1C332JX5
6	3513-999-60009	CAP 3N9 2% PL FLM 16V	0805	Preferred	Manufacturer Parts.Active	Panasonic	ECHU1C392GX5
7	3513-999-60105	CAP 1p ±0p25 C 50V C0G ( 0402 )	0402	Preferred	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H1R0CA01[]	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H1R0BA01[]	Manufacturer Parts.Obsolete	Samsung Electro-Mechanics GmbH	CL05C010BB5NNNC	Manufacturer Parts.Active	AVX Kyocera	04025A1R0BAT2A	Manufacturer Parts.Active	Murata Electronics UK Ltd	GCM1555C1H1R0BA16[]	Manufacturer Parts.Active	Murata Electronics UK Ltd	GJM1555C1H1R0BB01[]
8	3513-999-60106	CAP 1p2 ±0p25 50V C0G ( 0402 )	0402	Preferred	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H1R2CA01[]	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H1R2BA01[]	Manufacturer Parts.Obsolete	Samsung Electro-Mechanics GmbH	CL05C1R2BB5NNNC	Manufacturer Parts.Active	AVX Kyocera	04025A1R2BAT2A	Manufacturer Parts.Active	Murata Electronics UK Ltd	GJM1555C1H1R2BB01[]	Manufacturer Parts.Active	Murata Electronics UK Ltd	GCM1555C1H1R2BA16[]
9	3513-999-60107	CAP 1p5 ±0p25 C 50V C0G ( 0402 )	0402	Preferred	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H1R5CA01[]	Manufacturer parts.Active - Not Recommended for New Designs	Murata Electronics UK Ltd	GRM1555C1H1R5BA01-[]	Manufacturer Parts.Active	Samsung Electro-Mechanics GmbH	CL05C1R5BB5NNNC	Manufacturer Parts.Active	AVX Kyocera	04025A1R5BAT2A	Manufacturer Parts.Active	Murata Electronics UK Ltd	GJM1555C1H1R5BB01[]	Manufacturer Parts.Active	Murata Electronics UK Ltd	GCM1555C1H1R5BA16[]
Sheet0

 

[mumps]

Try:

Sub TransposeData()
    Application.ScreenUpdating = False
    Dim lRow As Long, i As Long, rCount As Long, dic As Object, v As Variant, srcWS As Worksheet, desWS As Worksheet, rng As Range
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 7).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v) To UBound(v)
        If Not dic.exists(v(i, 1)) Then
            dic.Add v(i, 1), Nothing
            With srcWS.Cells(1).CurrentRegion
                .AutoFilter 1, v(i, 1)
                rCount = srcWS.[subtotal(103,A:A)] - 1
                If rCount = 1 Then
                    desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 7).Value = Array(v(i, 1), v(i, 2), v(i, 3), v(i, 4), v(i, 5), v(i, 6), v(i, 7))
                Else
                    With desWS
                        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                        .Range("A" & lRow).Resize(, 7).Value = Array(v(i, 1), v(i, 2), v(i, 3), v(i, 4), v(i, 5), v(i, 6), v(i, 7))
                        For Each rng In srcWS.Range("F2", srcWS.Range("F" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
                            .Cells(lRow, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(, 3).Value = Array(rng.Offset(, -1), rng, rng.Offset(, 1))
                        Next rng
                    End With
                End If
            End With
        End If
    Next i
    desWS.Columns.AutoFit
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[MattGS]

Hi Mumps,

wanted to write to say a huge thank you this has really helped.

 

[mumps]

You are very welcome.