Transposing cells using macro and adding additional data

[Xlitup]

Hey Guys, in a bit of a pickle. How do I transpose cells from Columns to rows using a macro and also include the Asset Number and Date next to its respective element.

Asset Number	Date	Iron	Cr	Nickel	Al	Pb	Cu	Silver
TA20	12/12/2018	24	25	26	52	45	85	65
TA22	10/04/2018	65	875	45	895	45	25	21

<tbody>
</tbody>

Element	Value	Asset Number	Date
Iron	24	TA20	12/12/2018
Cr	25	TA20	12/12/2018
Nickel	26	TA20	12/12/2018
Al	52	TA20	12/12/2018
Pb	45	TA20	12/12/2018
Cu	85	TA20	12/12/2018
Silver	65	TA20	12/12/2018
Iron	65	TA22	10/04/2018
Cr	875	TA22	10/04/2018
Nickel	45	TA22	10/04/2018
Al	895	TA22	10/04/2018
Pb	45	TA22	10/04/2018
Cu	25	TA22	10/04/2018
Silver	21	TA22	10/04/2018

<tbody>
</tbody>

Don't know exactly how to explain the title but hopefully the example helps.
Thanks for helping in advance.

 

[alansidman]

Using Power Query here is the Mcode for you.

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(Source, {"Asset Number", "Date"}, "Attribute", "Value"),
    #"Renamed Columns" = Table.RenameColumns(#"Unpivoted Other Columns",{{"Attribute", "Element"}}),
    #"Reordered Columns" = Table.ReorderColumns(#"Renamed Columns",{"Element", "Value", "Asset Number", "Date"})
in
    #"Reordered Columns"

 

[Xlitup]

@alansidman thanks for the quick response but any other way than using Power Query.

Cheers.

 

[Xlitup]

@alansidman Sorry mate just tried using Power Query and worked like a charm. You absolute legend.

Cheers.

 

[alansidman]

Option Explicit


Sub TransChem()
    Dim s1 As Worksheet, s2 As Worksheet
    Dim lr As Long, lr2 As Long
    Dim i As Long, arr As Variant
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    Application.ScreenUpdating = False
    lr = s1.Range("A" & Rows.Count).End(xlUp).Row
    arr = Array("Asset Number", "Date", "Element", "Value")
    s2.Range("A1:D1") = arr
    For i = 2 To lr
        lr2 = s2.Range("C" & Rows.Count).End(xlUp).Row
        s1.Range("A" & i & ":B" & i).Copy s2.Range("A" & lr2 + 1)
        s1.Range("C1:I1").Copy
        s2.Range("C" & lr2 + 1).PasteSpecial xlPasteValues, , , True
        s1.Range("C" & i & ":I" & i).Copy
        s2.Range("D" & lr2 + 1).PasteSpecial xlPasteValues, , , True
    Next i
    lr2 = s2.Range("C" & Rows.Count).End(xlUp).Row
    For i = 3 To lr2
        If s2.Range("A" & i) = "" Then
            s2.Range("A" & i) = s2.Range("A" & i - 1)
            s2.Range("B" & i) = s2.Range("B" & i - 1)
        End If
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Complete"


End Sub