Rows of data from columns - not simple transpose.

J

Jazzledizzle

New Member
Joined
Jul 20, 2020
Messages
7
Office Version
  1. 365
Platform
  1. Windows
Hi, I'm sorry if I don't follow all of the rules as this is my first post, I may have missed some of them,

My current problem is I need to create one line of data from the table below, which contains a lot more data than just shown below, but as an example, I need to transform the data into one row, per unique lead reference. by example i'd need something like the row of data, from the table.

Output required:
LeadReferenceClientiD1ClientiD2ClientiD3ClientiD4ClientiD5ClientiD6ClientiD7ClientiD8ClientiD9ClientiD10ClientiD11Title1Title2Title3Title4Title5Title6Title7Title8Title9Title10Title11Forename1Forename2Forename3Forename4Forename5Forename6Forename7Forename8Forename9Forename10
90780390​
90780397​
90780390​
90780399​
90780391​
90780400​
90780392​
90780401​
90780394​
90780402​
90780396​
GroupGroupGroupGroupGroupGroupGroupGroupGroupGroup

Main table
Lead ReferenceCustomer ReferenceTitleForenameSurnameCompanyArea_desc2 1Row 1Start_seat 1No_seats 1Cost 1Ticket Net £VAT @ 20%GrossDining NetVAT @ 5%GrossTotalPrice_Band 1
90780390​
90780397​
GroupBT GroupM07
40​
162​
1​
8503​
1​
1​
2​
1​
1​
2​
0​
Arnold Hills EXEC
90780390​
90780390​
GroupBT GroupM07
39​
161​
1​
8503​
2​
2​
3​
2​
2​
3​
Arnold Hills EXEC
90780390​
90780399​
GroupBT GroupM07
40​
161​
1​
8503​
3​
3​
4​
3​
3​
4​
Arnold Hills EXEC
90780390​
90780391​
GroupBT GroupM07
39​
160​
1​
8503​
4​
4​
4​
4​
4​
5​
Arnold Hills EXEC
90780390​
90780400​
GroupBT GroupM07
40​
160​
1​
8503​
5​
5​
5​
5​
5​
6​
Arnold Hills EXEC
90780390​
90780392​
GroupBT GroupM07
39​
159​
1​
8503​
6​
6​
5.7​
6​
6​
7​
Arnold Hills EXEC
90780390​
90780401​
GroupBT GroupM07
40​
159​
1​
8503​
7​
7​
6.4​
7​
7​
8​
Arnold Hills EXEC
90780390​
90780394​
GroupBT GroupM07
39​
158​
1​
8503​
8​
8​
7.1​
8​
8​
9​
Arnold Hills EXEC
90780390​
90780402​
GroupBT GroupM07
40​
158​
1​
8503​
9​
9​
7.8​
9​
9​
10​
Arnold Hills EXEC
90780390​
90780396​
GroupBT GroupM07
39​
157​
1​
8503​
10​
10​
8.5​
10​
10​
11​
Arnold Hills EXEC
 
Sort by date Sort by votes
You have two columns with the same headers. Before trying this macro, change the first "Gross" to "Gross1" and the second "Gross" to "Gross2". Make sure you never have duplicate headers.
VBA Code: 
Sub TransposeData()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object, srcWS As Worksheet, desWS As Worksheet, key As Variant
    Dim rowCount As Long, LastRow As Long, lCol As Long, lCol2 As Long, x As Long
    Dim WorkRng As Range, xMax As Long, dic As Object
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = srcWS.Cells(1, Columns.Count).End(xlToLeft).Column
    desWS.Range("A1") = "Lead Reference"
    Set dic = CreateObject("scripting.dictionary")
    With srcWS
        Set WorkRng = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
        xMax = 0
        For Each Rng In WorkRng
            xValue = Rng.Value
            If xValue <> "" Then
                dic(xValue) = dic(xValue) + 1
                xCount = dic(xValue)
                If xCount > xMax Then
                    xMax = xCount
                End If
            End If
        Next Rng
    End With
    For x = 2 To lCol
        With desWS
            lCol2 = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
            For y = lCol2 To lCol2 + xMax - 1
                .Cells(1, y) = srcWS.Cells(1, x) & "-" & z
                z = z + 1
            Next y
        End With
        z = 1
    Next x
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each Rng In srcWS.Range("A2", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp))
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next
    For Each key In RngList
        With srcWS
            .Cells(1, 1).CurrentRegion.AutoFilter 1, key
            rowCount = .[subtotal(103,A:A)] - 1
            desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1) = key
            For x = 2 To lCol
                With desWS
                    Set fnd = desWS.Rows(1).Find(srcWS.Cells(1, x), LookIn:=xlValues, lookat:=xlPart)
                    If Not fnd Is Nothing Then
                        srcWS.Range(srcWS.Cells(2, x), srcWS.Cells(LastRow, x)).SpecialCells(xlCellTypeVisible).Copy
                        .Cells(.Rows.Count, fnd.Column).End(xlUp).Offset(1).PasteSpecial Transpose:=True
                    End If
                End With
            Next x
        End With
    Next key
    srcWS.Range("A1").AutoFilter
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
 
Upvote 0

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
mumps said:
You have two columns with the same headers. Before trying this macro, change the first "Gross" to "Gross1" and the second "Gross" to "Gross2". Make sure you never have duplicate headers.
VBA Code: 
Sub TransposeData()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object, srcWS As Worksheet, desWS As Worksheet, key As Variant
    Dim rowCount As Long, LastRow As Long, lCol As Long, lCol2 As Long, x As Long
    Dim WorkRng As Range, xMax As Long, dic As Object
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = srcWS.Cells(1, Columns.Count).End(xlToLeft).Column
    desWS.Range("A1") = "Lead Reference"
    Set dic = CreateObject("scripting.dictionary")
    With srcWS
        Set WorkRng = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
        xMax = 0
        For Each Rng In WorkRng
            xValue = Rng.Value
            If xValue <> "" Then
                dic(xValue) = dic(xValue) + 1
                xCount = dic(xValue)
                If xCount > xMax Then
                    xMax = xCount
                End If
            End If
        Next Rng
    End With
    For x = 2 To lCol
        With desWS
            lCol2 = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
            For y = lCol2 To lCol2 + xMax - 1
                .Cells(1, y) = srcWS.Cells(1, x) & "-" & z
                z = z + 1
            Next y
        End With
        z = 1
    Next x
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each Rng In srcWS.Range("A2", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp))
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next
    For Each key In RngList
        With srcWS
            .Cells(1, 1).CurrentRegion.AutoFilter 1, key
            rowCount = .[subtotal(103,A:A)] - 1
            desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1) = key
            For x = 2 To lCol
                With desWS
                    Set fnd = desWS.Rows(1).Find(srcWS.Cells(1, x), LookIn:=xlValues, lookat:=xlPart)
                    If Not fnd Is Nothing Then
                        srcWS.Range(srcWS.Cells(2, x), srcWS.Cells(LastRow, x)).SpecialCells(xlCellTypeVisible).Copy
                        .Cells(.Rows.Count, fnd.Column).End(xlUp).Offset(1).PasteSpecial Transpose:=True
                    End If
                End With
            Next x
        End With
    Next key
    srcWS.Range("A1").AutoFilter
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
Click to expand...
Thank you so much, I tested this, the only problem was for some of the fields that started with blank cells, the data was populated from subsequent rows. The company data has come from another person for example under 90801167 there is Normura holdings under company where it should be for 90054370

For example:
Output
Lead ReferenceCustomer Reference-Customer Reference-1Customer Reference-2Customer Reference-3Customer Reference-4Customer Reference-5Customer Reference-6Customer Reference-7Customer Reference-8Customer Reference-9Customer Reference-10Customer Reference-11Block-1Block-2Block-3Block-4Block-5Block-6Block-7Block-8Block-9Block-10Block-11Block-12Row-1Row-2Row-3Row-4Row-5Row-6Row-7Row-8Row-9Row-10Row-11Row-12Seat-1Seat-2Seat-3Seat-4Seat-5Seat-6Seat-7Seat-8Seat-9Seat-10Seat-11Seat-12No_seats 1-1No_seats 1-2No_seats 1-3No_seats 1-4No_seats 1-5No_seats 1-6No_seats 1-7No_seats 1-8No_seats 1-9No_seats 1-10No_seats 1-11No_seats 1-12Cost 1-1Cost 1-2Cost 1-3Cost 1-4Cost 1-5Cost 1-6Cost 1-7Cost 1-8Cost 1-9Cost 1-10Cost 1-11Cost 1-12Ticket Net £-1Ticket Net £-2Ticket Net £-3Ticket Net £-4Ticket Net £-5Ticket Net £-6Ticket Net £-7Ticket Net £-8Ticket Net £-9Ticket Net £-10Ticket Net £-11Ticket Net £-12VAT @ 20%-1VAT @ 20%-2VAT @ 20%-3VAT @ 20%-4VAT @ 20%-5VAT @ 20%-6VAT @ 20%-7VAT @ 20%-8VAT @ 20%-9VAT @ 20%-10VAT @ 20%-11VAT @ 20%-12Gross-1Gross-2Gross-3Gross-4Gross-5Gross-6Gross-7Gross-8Gross-9Gross-10Gross-11Gross-12Dining Net-1Dining Net-2Dining Net-3Dining Net-4Dining Net-5Dining Net-6Dining Net-7Dining Net-8Dining Net-9Dining Net-10Dining Net-11Dining Net-12VAT @ 5%-1VAT @ 5%-2VAT @ 5%-3VAT @ 5%-4VAT @ 5%-5VAT @ 5%-6VAT @ 5%-7VAT @ 5%-8VAT @ 5%-9VAT @ 5%-10VAT @ 5%-11VAT @ 5%-12Dining Gross-1Dining Gross-2Dining Gross-3Dining Gross-4Dining Gross-5Dining Gross-6Dining Gross-7Dining Gross-8Dining Gross-9Dining Gross-10Dining Gross-11Dining Gross-12Total-1Total-2Total-3Total-4Total-5Total-6Total-7Total-8Total-9Total-10Total-11Total-12Price_Band 1-1Price_Band 1-2Price_Band 1-3Price_Band 1-4Price_Band 1-5Price_Band 1-6Price_Band 1-7Price_Band 1-8Price_Band 1-9Price_Band 1-10Price_Band 1-11Price_Band 1-12Title-1Title-2Title-3Title-4Title-5Title-6Title-7Title-8Title-9Title-10Title-11Title-12Forename-1Forename-2Forename-3Forename-4Forename-5Forename-6Forename-7Forename-8Forename-9Forename-10Forename-11Forename-12Surname-1Surname-2Surname-3Surname-4Surname-5Surname-6Surname-7Surname-8Surname-9Surname-10Surname-11Surname-12Company-1Company-2Company-3Company-4Company-5Company-6Company-7Company-8Company-9Company-10Company-11Company-12DOB-1DOB-2DOB-3DOB-4DOB-5DOB-6DOB-7DOB-8DOB-9DOB-10DOB-11DOB-12AddrLine1-1AddrLine1-2AddrLine1-3AddrLine1-4AddrLine1-5AddrLine1-6AddrLine1-7AddrLine1-8AddrLine1-9AddrLine1-10AddrLine1-11AddrLine1-12AddrLine2-1AddrLine2-2AddrLine2-3AddrLine2-4AddrLine2-5AddrLine2-6AddrLine2-7AddrLine2-8AddrLine2-9AddrLine2-10AddrLine2-11AddrLine2-12AddrLine3-1AddrLine3-2AddrLine3-3AddrLine3-4AddrLine3-5AddrLine3-6AddrLine3-7AddrLine3-8AddrLine3-9AddrLine3-10AddrLine3-11AddrLine3-12AddrLine4-1AddrLine4-2AddrLine4-3AddrLine4-4AddrLine4-5AddrLine4-6AddrLine4-7AddrLine4-8AddrLine4-9AddrLine4-10AddrLine4-11AddrLine4-12AddrLine5-1AddrLine5-2AddrLine5-3AddrLine5-4AddrLine5-5AddrLine5-6AddrLine5-7AddrLine5-8AddrLine5-9AddrLine5-10AddrLine5-11AddrLine5-12PostCode-1PostCode-2PostCode-3PostCode-4PostCode-5PostCode-6PostCode-7PostCode-8PostCode-9PostCode-10PostCode-11PostCode-12Country-1Country-2Country-3Country-4Country-5Country-6Country-7Country-8Country-9Country-10Country-11Country-12Tel_day-1Tel_day-2Tel_day-3Tel_day-4Tel_day-5Tel_day-6Tel_day-7Tel_day-8Tel_day-9Tel_day-10Tel_day-11Tel_day-12Tel_eve-1Tel_eve-2Tel_eve-3Tel_eve-4Tel_eve-5Tel_eve-6Tel_eve-7Tel_eve-8Tel_eve-9Tel_eve-10Tel_eve-11Tel_eve-12Mobile Number-1Mobile Number-2Mobile Number-3Mobile Number-4Mobile Number-5Mobile Number-6Mobile Number-7Mobile Number-8Mobile Number-9Mobile Number-10Mobile Number-11Mobile Number-12Email Address-1Email Address-2Email Address-3Email Address-4Email Address-5Email Address-6Email Address-7Email Address-8Email Address-9Email Address-10Email Address-11Email Address-12
90801167​
90801167​
90801168​
M05M05
35​
35​
191​
190​
1​
1​
5508​
5508​
#REF!​
Arnold Hills EXECArnold Hills EXECMrMrIanIanAgatesAgatesNomura HoldingsNomura HoldingsNomura Holdings
########​
Loughton DevelopmentsLoughton Developments11 Woodbury Hill11 Woodbury HillCoopersale Street, CoopersaleCoopersale Street, CoopersaleCoopersale Street, CoopersaleCoopersale Street, CoopersaleLOUGHTONLOUGHTONEssexEssexIG10 1JBIG10 1JBUnited KingdomUnited Kingdom
2.08E+09​
2.08E+09​
2.08E+09​
2.08E+09​
2.08E+09​
2.08E+09​
2.08E+09​
2.08E+09​
7.73E+09​
7.73E+09​
7.73E+09​
7.73E+09​
agates.ian@gmail.comagates.ian@gmail.com
90054370​
90054370​
90054369​
90054372​
90054371​
M07M07M07M07
34​
34​
34​
34​
162​
161​
160​
159​
1​
1​
1​
1​
5008​
5008​
5008​
5008​
Arnold Hills EXECArnold Hills EXECArnold Hills EXECArnold Hills EXECMrMrMrMrFurqanFurqanFurqanFurqanAnwerAnwerAnwerAnwerCapsicumCapsicumCapsicumCapsicum
########​
26 Overton Drive26 Overton Drive26 Overton Drive26 Overton DriveWansteadWansteadWansteadWansteadStation StreetStation StreetLONDONLONDONLONDONLONDONEssexEssexEssexEssexE11 2NJE11 2NJE11 2NJE11 2NJUnited KingdomUnited KingdomUnited KingdomUnited Kingdom
2.09E+09​
2.09E+09​
2.09E+09​
2.09E+09​
7.89E+09​
7.89E+09​
7.89E+09​
7.89E+09​
smfa7@hotmail.comsmfa7@hotmail.comSmfa7@hotmail.comvcsmgroup@gmail.com

Data:
Lead ReferenceCustomer ReferenceBlockRowSeatNo_seats 1Cost 1Ticket Net £VAT @ 20%GrossDining NetVAT @ 5%Dining GrossTotalPrice_Band 1TitleForenameSurnameCompanyDOBAddrLine1AddrLine2AddrLine3AddrLine4AddrLine5PostCodeCountryTel_dayTel_eveMobile NumberEmail Address
90801167​
90801167​
M05
35​
191​
1​
5508​
Arnold Hills EXECMrIanAgatesLoughton Developments11 Woodbury HillLOUGHTONEssexIG10 1JBUnited Kingdomagates.ian@gmail.com
90801167​
90801168​
M05
35​
190​
1​
5508​
Arnold Hills EXECMrIanAgatesLoughton Developments11 Woodbury HillLOUGHTONEssexIG10 1JBUnited Kingdomagates.ian@gmail.com
90054370​
90054370​
M07
34​
162​
1​
5008​
Arnold Hills EXECMrFurqanAnwer26 Overton DriveWansteadLONDONE11 2NJUnited Kingdom
7727604478​
smfa7@hotmail.com
90054370​
90054369​
M07
34​
161​
1​
5008​
Arnold Hills EXECMrFurqanAnwer26 Overton DriveWansteadLONDONE11 2NJUnited Kingdom
7727604478​
smfa7@hotmail.com
90054370​
90054372​
M07
34​
160​
1​
5008​
Arnold Hills EXECMrFurqanAnwer
29/11/1980​
26 Overton DriveWansteadLONDONE11 2NJUnited Kingdom
7727604478​
Smfa7@hotmail.com
90054370​
90054371​
M07
34​
159​
1​
5008​
Arnold Hills EXECMrFurqanAnwer26 Overton DriveWansteadLONDONE11 2NJUnited Kingdom
7727604478​
vcsmgroup@gmail.com
90112041​
90112041​
M05
33​
191​
1​
5258​
Arnold Hills EXECMrStevenAshleyNomura HoldingsNomura Holdings1 Angel LaneLONDONEC4R 3ABUnited Kingdomjanice.reynolds@nomura.com
90112041​
90112043​
M05
33​
190​
1​
5258​
Arnold Hills EXECMrStevenAshleyNomura HoldingsNomura Holdings1 Angel LaneLONDONEC4R 3ABUnited Kingdom
7721754685​
janice.reynolds@nomura.com
90112041​
90112042​
M05
33​
189​
1​
5258​
Arnold Hills EXECMrStevenAshleyNomura HoldingsNomura Holdings1 Angel LaneLONDONEC4R 3ABUnited Kingdom
7721754685​
janice.reynolds@nomura.com
 
Upvote 0
Try:
VBA Code: 
Sub TransposeData()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object, srcWS As Worksheet, desWS As Worksheet, key As Variant
    Dim rowCount As Long, LastRow As Long, lRow As Long, lCol As Long, lCol2 As Long, x As Long
    Dim WorkRng As Range, xMax As Long, dic As Object
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = srcWS.Cells(1, Columns.Count).End(xlToLeft).Column
    desWS.Range("A1") = "Lead Reference"
    Set dic = CreateObject("scripting.dictionary")
    With srcWS
        Set WorkRng = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
        xMax = 0
        For Each Rng In WorkRng
            xValue = Rng.Value
            If xValue <> "" Then
                dic(xValue) = dic(xValue) + 1
                xCount = dic(xValue)
                If xCount > xMax Then
                    xMax = xCount
                End If
            End If
        Next Rng
    End With
    For x = 2 To lCol
        With desWS
            lCol2 = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
            For y = lCol2 To lCol2 + xMax - 1
                .Cells(1, y) = srcWS.Cells(1, x) & "-" & z
                z = z + 1
            Next y
        End With
        z = 1
    Next x
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each Rng In srcWS.Range("A2", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp))
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next
    For Each key In RngList
        With srcWS
            .Cells(1, 1).CurrentRegion.AutoFilter 1, key
            rowCount = .[subtotal(103,A:A)] - 1
            desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1) = key
            For x = 2 To lCol
                With desWS
                    Set fnd = desWS.Rows(1).Find(srcWS.Cells(1, x), LookIn:=xlValues, lookat:=xlPart)
                    If Not fnd Is Nothing Then
                        srcWS.Range(srcWS.Cells(2, x), srcWS.Cells(LastRow, x)).SpecialCells(xlCellTypeVisible).Copy
                        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        .Cells(lRow, fnd.Column).PasteSpecial Transpose:=True
                    End If
                End With
            Next x
        End With
    Next key
    srcWS.Range("A1").AutoFilter
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Solved
Transpose data.
Replies
4
Views
352
harzer
H
H
  • Question Question
Transposing Data - Evaluating formula to an array error.
Replies
1
Views
42
Skyybot
Skyybot
E
  • Solved
combine data from two worksheets with similar data but different formats
Replies
6
Views
91
DanteAmor
DanteAmor
SimonHughes
  • Solved
Transposing Info From Columns to Rows - Irregular Pattern
2
Replies
18
Views
423
SimonHughes
SimonHughes
T
  • Solved
Scaling a Data Set
Replies
6
Views
292
felixstraube
F

Forum statistics

Threads
1,223,885
Messages
6,175,187
Members
452,616
Latest member
intern444

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top