VBA Excel Stack multiple columns together / transpose

Question

Here is how the data is presented (it's in pivot table style but not a true pivot table):

and this is how I need it to transform to:

For each visit, which always start in column H and needs to finish before 'Total Activity Costs' (hence why I used offset of 5), I need information duplicated. I only need the rows for each visit to be present if there is a 1 against that row for that particular visit. In the second image, you can see that not all rows are present for each visit as they don't have a 1 in their column.

Some of the data is hard coded and other columns come from another sheet, as you'll see in the code.

The code I have written so far copies across to the "BuiltCosts" sheet but each visit is being overwritten each time the loop is run. I can see it's due to p=2.... but having Googled a lot, I simply cannot work out how to achieve my goal.

Here is the code for this particular part of the module:

 With ActiveSheet
    
    Dim lrrg As Range ' Do I need this?
    Set lrrg = Range("A1").CurrentRegion 'Do I need this?

    Dim lastcolumn As Long, lastrow As Long
    Dim p As Long
    Dim VisitCount As Long, VisitRange As Range


    lastrow = lrrg.Rows(lrrg.Rows.Count).Row + 1
     ' I need to use row 5
    lastcolumn = _
        ActiveSheet.Cells(5, ActiveSheet.Columns.Count).End(xlToLeft).Column

 'In row 5, column H to last column
     Set VisitRange = Range(Cells(5, 8), Cells(5, lastcolumn).Offset(0, -5)) 'I need the last column to be 5th from the far right
     Dim Visit As Range

     For Each Visit In VisitRange
         If Visit.Value <> "" Then

           For p = 2 To lastrow
             Sheets("BuiltCosts").Cells(p, 1) = Worksheets("Front_Page").Range("D8")
             Sheets("BuiltCosts").Cells(p, 2) = Worksheets("Front_Page").Range("D22") & "" & Worksheets("Front_Page").Range("G14") & " " & ActiveSheet.Range("C1") & " " & Visit
             Sheets("BuiltCosts").Cells(p, 3) = "Participant"
             Sheets("BuiltCosts").Cells(p, 6) = .Cells(p, 1) & " " & .Cells(p, 5)
             Sheets("BuiltCosts").Cells(p, 8) = "Research Cost"
             Sheets("BuiltCosts").Cells(p, 11) = .Cells(p, 3)
             Sheets("BuiltCosts").Cells(p, 13) = .Cells(p, 6)
             '*************The line below needs to be dynamic, so rather than .Cells(p, 8),
             'I need each column in turn to be used when it loops through the columns.
             '8 is the first column of the '1's that I want
             'Sheets("BuiltCosts").Cells(p, 14) = .Cells(p, 8)
            Next p

         End If
     Next Visit

End With

What you can do is to introduce another variable (BuiltCosts_pointer) assign a start value (BuiltCosts_pointer = 2) and increment within the For p = 2 To lastrow by 1. Use this variable on all the Sheets("BuiltCosts").Cells(BuiltCosts_pointer, 1....13) . If this is what you want. — Black cat
– Black cat, Commented Jul 20 at 17:16
Thank you for replying so quickly @Black cat. I added Dim BuiltCosts_pointer As Long. I placed BuiltCosts_pointer = 2 + 1 after the For p = 2 To lastrow line and replaced p with BuiltCosts_pointer in all the Sheets("BuiltCosts").Cells... rows. This results in only the first line being written to and being overwritten each time. I'm truly stuck. — Sally Parkes
– Sally Parkes, Commented Jul 20 at 18:06
The assignment is placed in the first line after With ActiveSheet and BuiltCosts_pointer = BuiltCosts_pointer +1 is before Next p. SIDENOTE: Referencing ActiveSheet is not a safe thing if not specifically need it. Better to use Worksheets(".......") structure to avoid incorrect reference. — Black cat
– Black cat, Commented Jul 20 at 18:37

CDP1802 · Accepted Answer · 2025-07-20 18:39:20Z

VisitRange is only row 5 so

For Each Visit In VisitRange         
    If Visit.Value <> "" Then

is not checking the rows of data from row 6 onwards. Try

Option Explicit

Sub unpivot()

    Dim wsIn As Worksheet, wsOut As Worksheet
    Dim arVisit, x
    Dim NoOfVisits As Long, lastrow As Long, lastcol As Long
    Dim n As Long, r As Long, c As Long, rOut As Long
    
    With ThisWorkbook
       Set wsIn = .Sheets("Front_Page")
       Set wsOut = .Sheets("BuiltCosts")
    End With
   
   ' Header
    wsOut.Range("A1:M1") = Array("EDGE Project ID", "Template Name", "Template Level (Project|Participant|ProjectSite)", _
                         "Project Arm (Participnat Only)", "Project Site Name (ProjectSite only", _
                         "Cost Item Description", "Analysis Code", "Cost Category", "Default Cost", _
                         "Currency", "Department", "OverHead", "Time")
    rOut = 1
                        
   ' calc number of visits from row 5
    With wsIn
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        lastcol = .Cells(5, .Columns.Count).End(xlToLeft).Column
        ' v1 1 is col 8
        NoOfVisits = lastcol - 12 ' 7 before and 5 after
        arVisit = .Cells(5, 8).Resize(, NoOfVisits)
                        
        ' Scan down sheet for each visit
        For n = 1 To NoOfVisits
            For r = 6 To lastrow
                x = .Cells(r, n + 7) ' 1
                If x <> 0 Then
                    rOut = rOut + 1                    
                    wsOut.Cells(rOut, "A") = "1234 ??"
                    wsOut.Cells(rOut, "B") = arVisit(1, n)                    
                    wsOut.Cells(rOut, "F") = .Cells(r, "A") & " " & .Cells(r, "E") ' Cost Item Description
                    wsOut.Cells(rOut, "G") = .Cells(r, "D") ' Analysis Code
                    wsOut.Cells(rOut, "H") = "Research Costs" ' Cost Category
                    wsOut.Cells(rOut, "J") = "GBP"
                    wsOut.Cells(rOut, "K") = .Cells(r, "C") ' Department
                    wsOut.Cells(rOut, "M") = .Cells(r, "F") ' Time
                    wsOut.Cells(rOut, "N") = x                    
                End If
            Next
        Next
    End With
   
   MsgBox rOut & " rows written to " & wsOut.Name, vbInformation

End Sub

That works perfectly; many thanks @CDP1802. Much appreciated.

Collectives™ on Stack Overflow

VBA Excel Stack multiple columns together / transpose

1 Answer 1

1 Comment

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

1 Comment

Your Answer

Sign up or log in

Post as a guest

Related