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.

[TABLE="width: 500"]
<tbody>[TR]
[TD]Asset Number[/TD]
[TD]Date[/TD]
[TD]Iron[/TD]
[TD]Cr[/TD]
[TD]Nickel[/TD]
[TD]Al[/TD]
[TD]Pb[/TD]
[TD]Cu[/TD]
[TD]Silver[/TD]
[/TR]
[TR]
[TD]TA20[/TD]
[TD]12/12/2018[/TD]
[TD]24[/TD]
[TD]25[/TD]
[TD]26[/TD]
[TD]52[/TD]
[TD]45[/TD]
[TD]85[/TD]
[TD]65[/TD]
[/TR]
[TR]
[TD]TA22[/TD]
[TD]10/04/2018[/TD]
[TD]65[/TD]
[TD]875[/TD]
[TD]45[/TD]
[TD]895[/TD]
[TD]45[/TD]
[TD]25[/TD]
[TD]21[/TD]
[/TR]
</tbody>[/TABLE]



[TABLE="width: 500"]
<tbody>[TR]
[TD]Element[/TD]
[TD]Value[/TD]
[TD]Asset Number[/TD]
[TD]Date[/TD]
[/TR]
[TR]
[TD]Iron[/TD]
[TD]24[/TD]
[TD]TA20[/TD]
[TD]12/12/2018[/TD]
[/TR]
[TR]
[TD]Cr[/TD]
[TD]25[/TD]
[TD]TA20[/TD]
[TD]12/12/2018[/TD]
[/TR]
[TR]
[TD]Nickel[/TD]
[TD]26[/TD]
[TD]TA20[/TD]
[TD]12/12/2018[/TD]
[/TR]
[TR]
[TD]Al[/TD]
[TD]52[/TD]
[TD]TA20[/TD]
[TD]12/12/2018[/TD]
[/TR]
[TR]
[TD]Pb[/TD]
[TD]45[/TD]
[TD]TA20[/TD]
[TD]12/12/2018[/TD]
[/TR]
[TR]
[TD]Cu[/TD]
[TD]85[/TD]
[TD]TA20[/TD]
[TD]12/12/2018[/TD]
[/TR]
[TR]
[TD]Silver[/TD]
[TD]65[/TD]
[TD]TA20[/TD]
[TD]12/12/2018[/TD]
[/TR]
[TR]
[TD]Iron[/TD]
[TD]65[/TD]
[TD]TA22[/TD]
[TD]10/04/2018[/TD]
[/TR]
[TR]
[TD]Cr[/TD]
[TD]875[/TD]
[TD]TA22[/TD]
[TD]10/04/2018[/TD]
[/TR]
[TR]
[TD]Nickel[/TD]
[TD]45[/TD]
[TD]TA22[/TD]
[TD]10/04/2018[/TD]
[/TR]
[TR]
[TD]Al[/TD]
[TD]895[/TD]
[TD]TA22[/TD]
[TD]10/04/2018[/TD]
[/TR]
[TR]
[TD]Pb[/TD]
[TD]45[/TD]
[TD]TA22[/TD]
[TD]10/04/2018[/TD]
[/TR]
[TR]
[TD]Cu[/TD]
[TD]25[/TD]
[TD]TA22[/TD]
[TD]10/04/2018[/TD]
[/TR]
[TR]
[TD]Silver[/TD]
[TD]21[/TD]
[TD]TA22[/TD]
[TD]10/04/2018[/TD]
[/TR]
</tbody>[/TABLE]

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