Generate Report - Macro

Hi Guys,

I have a report that should be generated monthly and currently I have this following code:

Sub CopyData()
Dim ws As Worksheet
Dim iLastRow As Long

Dim sActivity() As String
Dim sRecs1() As String
Dim sRecs2() As String


    iLastRow = LastRowInOneColumn
    Set ws = ActiveSheet
    For i = 1 To iLastRow
        
        sActivity = IIf(ws.Cells(i, 1) = "", Split("0 0", " "), Split(ws.Cells(i, 1), ":"))
        If sActivity(0) = "Activity Name" Then
        
            'How Many Content Records
            sRecs1 = IIf(ws.Cells(i + 1, 1) = "", Split("0 0", " "), Split(ws.Cells(i + 1, 1), " "))
            
            'How Many Result Records
            sRecs2 = IIf(ws.Cells(i + 1, 3) = "", Split("0 0", " "), Split(ws.Cells(i + 1, 3), " "))
            
            
                      
            If Int(sRecs1(0)) >= 1 And Int(sRecs2(0)) = 1 Then
                
                Range("B" & i + 2).Select
                ActiveCell.FormulaR1C1 = _
                "=RIGHT(R[-2]C[-1],LEN(R[-2]C[-1])-14)"
'                "=MID(R[-2]C[-1],FIND(""="",SUBSTITUTE(R[-2]C[-1],"":"",""="",LEN(R[-2]C[-1])-LEN(SUBSTITUTE(R[-2]C[-1],"":"",""""))))+1,256)"
                
                Selection.Copy
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
                
                
                Range("B" & i + 2 & ":" & "L" & i + 2).Select
                Selection.Copy
                Range("B" & i + 3 & ":" & "L" & i + 1 + Int(sRecs1(0))).Select
                ActiveSheet.Paste
                
                               
                i = i + 1 + Int(sRecs1(0))
                GoTo here
            End If
            
            If Int(sRecs1(0)) >= 1 And Int(sRecs2(0)) = 0 Then
                i = i + 1 + Int(sRecs1(0))
                GoTo here
            End If
            
            If Int(sRecs1(0)) = 0 And Int(sRecs2(0)) >= 1 Then
                i = i + 1 + Int(sRecs2(0))
                GoTo here
            End If
            
            If Int(sRecs1(0)) = 1 And Int(sRecs2(0)) >= 1 Then
                
                Range("B" & i + 2).Select
                ActiveCell.FormulaR1C1 = _
                "=MID(R[-2]C[-1],FIND(""="",SUBSTITUTE(R[-2]C[-1],"":"",""="",LEN(R[-2]C[-1])-LEN(SUBSTITUTE(R[-2]C[-1],"":"",""""))))+1,256)"
                Selection.Copy
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
                
                Range("A" & i + 2 & ":" & "B" & i + 2).Select
                Selection.Copy
                Range("A" & i + 3 & ":" & "B" & i + 1 + Int(sRecs2(0))).Select
                ActiveSheet.Paste
                
                i = i + 1 + Int(sRecs2(0))
                GoTo here
            End If
            
        End If
here:
        
    Next

End Sub

This code is only for records which either Content/Result column is 1 record:

test.jpg



Now, I am looking for a solution where both Content/Result is more than 1 record:

Untitled.jpg


This should be the result of the report:

Untitled2.jpg



I hope you could help me out!
Thanks.