VBA Excel Stack multiple columns together / transpose

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

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