Macro to Stack row of headers x times then next header xtimes in Column

[L VBA L]

I have some data with categories going across the top which I want to stack so the data set is repeated multiple times and only have 1 columns with results.

Turn it into this:

I managed to replicate the Food, Live Colour Categories but cant work out how to stack dog then catc then rabbit?


EDIT:
This data is all made up and may not make sense but its the principal i require.

 

[alansidman]

With Power Query, Unpivot your data

let
    Source = Excel.CurrentWorkbook(){[Name="Table2"]}[Content],
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(Source, {"Food", "Live", "Colour"}, "Attribute", "Value"),
    #"Sorted Rows" = Table.Sort(#"Unpivoted Other Columns",{{"Attribute", Order.Ascending}}),
    #"Reordered Columns" = Table.ReorderColumns(#"Sorted Rows",{"Attribute", "Food", "Live", "Colour", "Value"})
in
    #"Reordered Columns"

Power Query is a free AddIn for Excel 2010 and 2013, and is built-in functionality from Excel 2016 onwards (where it is referred to as "Get & Transform Data").

It is a powerful yet simple way of getting, changing and using data from a broad variety of sources, creating steps which may be easily repeated and refreshed. I strongly recommend learning how to use Power Query - it's among the most powerful functionalities of Excel.

- Follow this link to learn how to install Power Query in Excel 2010 / 2013.

The Complete Guide to Installing Power Query - Excel Campus

Learn what version you need to get Power Query and instructions on how to install this free add-in from Microsoft.

www.excelcampus.com

- Follow this link for an introduction to Power Query functionality.

Power Query Overview: An Introduction to Excel's Most Powerful Data Tool - Excel Campus

Learn how this FREE Excel add-in from Microsoft called Power Query will help transform your data into a format that is ready for pivot tables, reports and more.

www.excelcampus.com

- Follow this link for a video which demonstrates how to use Power Query code provided.

Power Query - How To Paste Code (video) - Excel Solutions

Power Query is great at solving data transformation and consolidation issues. But there are still loads of Excel users who have never used Power Query yet – and sometimes when they’re given some Power Query code to answer their question, they don’t know what to do with it. Here’s a short video...

excel.solutions

 

[L VBA L]

Apologies this may work but the names of the headers change between sheets and can be between 20-60 different names. Is there a way I don't have to type in the header names?

 

[Joe4]

Here is some VBA code that seems to do what you want:

Sub MyCopyData()

    Dim srcSht As Worksheet
    Dim dstSht As Worksheet
    Dim c1 As Long
    Dim c2 As Long
    Dim c3 As Long
    Dim c4 As Long
    Dim lr As Long
    Dim c As Long
    Dim nr As Long
    Dim nc As Long
    Dim hdr As String
    
    
'   Specify source sheet and destination sheet
    Set srcSht = Sheets("Sheet1")
    Set dstSht = Sheets("Sheet2")
    
'   Specify the starting and ending column for the descriptions
    c1 = 1  'first descriptive column in column A (1st column)
    c2 = 3  'last descriptive column in column C (3rd column)
    
    Application.ScreenUpdating = False

'   Populate title row on source sheet
    dstSht.Range("A1") = "Animal"
    srcSht.Range(srcSht.Cells(1, c1), srcSht.Cells(1, c2)).Copy dstSht.Range("B1")
    nc = dstSht.Cells(1, dstSht.Columns.Count).End(xlToLeft).Column + 1 'determine new column on destination sheet for totals
    dstSht.Cells(1, nc) = "Total"

'   Find last row with data on source sheet
    lr = srcSht.Cells(Rows.Count, c1).End(xlUp).Row
    
'   Calculate data columns to loop through
    c3 = c2 + 1
    c4 = srcSht.Cells(1, Columns.Count).End(xlToLeft).Column
    
'   Verify there are columns to data to go through
    If c3 > c4 Then
        MsgBox "Please fix data or VBA code", vbOKOnly, "There does not seem to be any data columns to go through!"
        Exit Sub
    End If
    
'   Loop through data columns
    For c = c3 To c4
'       Grab column header
        hdr = srcSht.Cells(1, c)
'       Determine next available row on Source sheet
        nr = dstSht.Cells(dstSht.Rows.Count, "A").End(xlUp).Row + 1
'       Populate the new data
        dstSht.Range(dstSht.Cells(nr, "A"), dstSht.Cells(nr + lr - 2, "A")) = hdr 'populate header value in first column
        srcSht.Range(srcSht.Cells(2, c1), srcSht.Cells(lr, c2)).Copy dstSht.Cells(nr, 2) 'copy over descriptive data to next columns
        srcSht.Range(srcSht.Cells(2, c), srcSht.Cells(lr, c)).Copy dstSht.Cells(nr, nc)   'copy over totals column
    Next c
    
    Application.ScreenUpdating = True
    
End Sub

I am assuming your first list starts in A1.
I tried to make it general enough that you should only have to edit the few items in red to suit your needs.

Here is the sample data from Sheet1:

and here is the output it produced on Sheet2: