Swapping Rows & Colums

[MrBez]

Hi All,

Wondering if any of you out there could help with a problem I have in re-arranging some columns and rows.

Below is an example of the data as it is:

Customer	FR	DFL	TP	DLG
A	5	1	0	32
B	10	20	30	14

<tbody>
</tbody>

I am needing to have the data organised like:

Customer	Product	Amount
A	FR	5
A	DFL	1
A	TP	0
A	DLG	32
B	FR	5
B	DFL	16
B	TP	20
B	DLG	19

<tbody>
</tbody>

Help !

Any solutions would be GREATLY appreciated

 

[MrKowz]

Give this code a shot.

Note, you may need to change "Sheet1" and "Sheet2" (highlighted) to reflect the names of the worksheets in your workbook.

Public Sub TranspostList()
Dim i       As Long, _
    j       As Long, _
    sLR     As Long, _
    sLC     As Long, _
    dLR     As Long
    
Dim sWS     As Worksheet, _
    dWS     As Worksheet
    
Dim rCust   As String
    
With Application
    .ScreenUpdating = False
End With
    
Set sWS = Sheets([COLOR="#FF0000"]"Sheet1"[/COLOR])
Set dWS = Sheets([COLOR="#FF0000"]"Sheet2"[/COLOR])
    
sLR = Range("A" & Rows.Count).End(xlUp).Row
sLC = Cells(1, Columns.Count).End(xlToLeft).Column

dWS.Range("A1").Value = "Customer"
dWS.Range("B1").Value = "Product"
dWS.Range("C1").Value = "Amount"

For i = 2 To sLR
    rCust = sWS.Range("A" & i).Value
    dLR = dWS.Range("A" & Rows.Count).End(xlUp).Row + 1
    For j = 0 To sLC - 2
        dWS.Range("A" & dLR + j).Value = rCust
        dWS.Range("B" & dLR + j).Value = sWS.Cells(1, j + 2)
        dWS.Range("C" & dLR + j).Value = sWS.Cells(i, j + 2)
    Next j
Next i

With Application
    .ScreenUpdating = True
End With
End Sub

 

[MrBez]

That worked amazingly..... spot on !

Thanks so so much, saved me alot of time !

 

[MrKowz]

That worked amazingly..... spot on !

Thanks so so much, saved me alot of time !

Happy to help. Have a great day!