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:

 

[L VBA L]

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:
View attachment 117983

and here is the output it produced on Sheet2:
View attachment 117984

This worked great. My data didn't start in A1 (actually C10) but I managed to update this and it worked spot on.

I did encounter an issue though as my data has between 3-40 columns for the Animals then a repeat of these columns to show a different cost which I dont want to pull through. In essence it created a duplicate set of rows for the second set of data.

I assume this is due to the VBA going to the last column to stop. If I added a cell that did a count of the number of columns I wanted it to do the above for could we work that into the formula?

Thanks again.

 

[Joe4]

This worked great. My data didn't start in A1 (actually C10) but I managed to update this and it worked spot on.

I did encounter an issue though as my data has between 3-40 columns for the Animals then a repeat of these columns to show a different cost which I dont want to pull through. In essence it created a duplicate set of rows for the second set of data.

I assume this is due to the VBA going to the last column to stop. If I added a cell that did a count of the number of columns I wanted it to do the above for could we work that into the formula?

Thanks again.

I don't understand what you are saying.
Can you show us an example data image to describe what you are trying to say?

 

[L VBA L]

There are about 40 columns from E that could be used and sometimes are blank like the above. Then there are another 40 columns that is doing a calculation (like L-M above) but I dont need them for this exercise, I'm only interested in up to G so I could add a cell somewhere counting the columns I'm interested in ie 3 from the above and refer to this cell to decide how many columns to loop through.

Does this make sense?

Thanks

 

[Joe4]

If you change this line of code:

    c4 = srcSht.Cells(1, Columns.Count).End(xlToLeft).Column

to this:

    c4 = srcSht.Cells(1, 1).End(xlToRight).Column

instead of choosing the last column with data in row 1, it will start in column A and go out to the last column before the first blank (column G).
So I think that should do what you want.