VBA/Formula logic advice - excel

Question

I have a VBA/Formula logic issue which I hope to pick your brains on.
Step 1
User completes a data table from Column C Row 2 onward which tells a macro how many times to duplicate the row by per Column B Row 2.
I have a formula which then populates Column A Row 2 with the column header:
=IF(COUNTA($B2:$D2)=0,"",INDEX($B$1:$G$1,MATCH(FALSE,INDEX(ISBLANK($B2:$G2),0),0)))
The above formula will only populate the first column Name which is great if we are not duplicating the rows. However, the issue is that I need to populate the column header of the row that has been duplicated so it looks at the column after the first one of that row.
Step 2
This is what the finished data table should look like:
Example
Any advice would be appreciated.

Answer 1

Option Explicit
Const TitleRow As Integer = 1
Const StartGenColumn As Integer = 47 ' AU
Sub GenerateRows()
Dim SrcRow As Integer, DestRow As Integer, SrcCol As Integer
Dim NumCoreColumns As Integer, LastGenColumn As Integer
Dim SrcWS As Worksheet, DestWS As Worksheet
Dim i As Integer
NumCoreColumns = StartGenColumn - 1
' find the last column
LastGenColumn = ActiveSheet.Cells(TitleRow, ActiveSheet.Columns.Count).End(xlToLeft).Column
' check if it has the totals
If InStr(ActiveSheet.Cells(TitleRow + 1, LastGenColumn).Formula, "SUM") Then
LastGenColumn = LastGenColumn - 1
Else
' put in a total so that we can tell when we've finished processing
ActiveSheet.Cells(TitleRow + 1, LastGenColumn + 1).Formula = "=SUM(" & ColLetter(StartGenColumn) & (TitleRow + 1) & _
":" & ColLetter(LastGenColumn) & (TitleRow + 1) & ")"
' fill down
ActiveSheet.Range(Cells(TitleRow + 1, LastGenColumn + 1), Cells(ActiveSheet.Rows.Count, LastGenColumn + 1)).FillDown
End If
Set SrcWS = ActiveSheet
If LastGenColumn > StartGenColumn Then
' create the new worksheet
Worksheets.Add
Set DestWS = ActiveSheet
Application.ScreenUpdating = False
' populate the titles
SrcWS.Range(SrcWS.Cells(TitleRow, 1), SrcWS.Cells(TitleRow, NumCoreColumns)).Copy
' always at top of new sheet
DestWS.Range(DestWS.Cells(1, 1), DestWS.Cells(1, NumCoreColumns)).PasteSpecial xlPasteAll
SrcRow = TitleRow + 1
DestRow = 2
' while we still have something to do
Do While SrcWS.Cells(SrcRow, LastGenColumn + 1) <> "" And SrcWS.Cells(SrcRow, LastGenColumn + 1) > 0
' copy the core data
SrcWS.Range(SrcWS.Cells(SrcRow, 1), SrcWS.Cells(SrcRow, NumCoreColumns)).Copy
' what to we need to generate
For SrcCol = StartGenColumn To LastGenColumn
For i = 1 To SrcWS.Cells(SrcRow, SrcCol).Value
DestWS.Range(DestWS.Cells(DestRow, 1), DestWS.Cells(DestRow, NumCoreColumns)).PasteSpecial xlPasteAll
' copy in the title and colour
DestWS.Cells(DestRow, 1).Value = SrcWS.Cells(TitleRow, SrcCol).Value
DestWS.Cells(DestRow, 1).Interior.Color = SrcWS.Cells(TitleRow, SrcCol).Interior.Color
DestRow = DestRow + 1
Next i
Next SrcCol
SrcRow = SrcRow + 1
Loop
Application.CutCopyMode = False
DestWS.Cells(1, 1).EntireColumn.AutoFit
Application.ScreenUpdating = True
End If
End Sub
Private Function ColLetter(Col As Integer) As String
Dim Arr
Arr = Split(Cells(1, Col).Address(True, False), "$")
ColLetter = Arr(0)
End Function