How to copy and paste a group of columns multiple times based on value?

[YD93309]

I'm a new VBA learner. I am going to make a summary sheet for this kind form: See the attachment 1


Eventually, this workbook will have more than 120 forms, I want to use VBA to loop all forms, then make a summary sheet in the same workbook for them. All forms have the same format as the image shows.
Here is an example I made:
The really complicated code I have now (I combined it from other's help):

Sub extractdata()
Dim ws As Worksheet
Application.ScreenUpdating = False
'GET BASIC DATA FROM THE SHEET
For Each ws In Worksheets
       If ws.Name Like "*" & "FormB" Then
            'Get the duplicated number of people and tasks:
            'G2=COUNTA(B2:F2);H2=COUNTA(A4:A7);I2=G2*H2
            ws.Range("G2:I5").Copy 
            Worksheets("Summary").Cells(Rows.Count, "O").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            ws.Range("A4:A6").Copy 'Get the task description
            Worksheets("Summary").Cells(Rows.Count, "H").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            ws.Range("B2:F7").Copy 'Get the people's information
            Worksheets("Summary").Cells(Rows.Count, "I").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
        End If
        Next ws

End Sub

Sub Duplicate1()
Application.ScreenUpdating = False
'DUPLICATE THE ROW "O" BASED ON THE DUPLICATED TIMES 2(ColP)
Dim CurrentRow As Long
Dim currentNewSheetRow As Long: currentNewSheetRow = 1
Sheets("Summary").Activate
For CurrentRow = 2 To 20000
Dim timesToDuplicate As Integer
timesToDuplicate = CInt(Worksheets("Summary").Range("P" & CurrentRow).Value) 'THE DUPLICATED TIMES 2
Dim i As Integer
For i = 1 To timesToDuplicate
    With Worksheets("Summary")
    .Range("R" & currentNewSheetRow).Offset(1, 0).Value = Worksheets("Summary").Range("O" & CurrentRow).Value
     End With
    currentNewSheetRow = currentNewSheetRow + 1
    Next i
Next CurrentRow
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Sub Duplicate2()
Application.ScreenUpdating = False
'DUPLICATE THE ROW "H" BASED ON THE DUPLICATED TIMES 4(ColR)
Dim CurrentRow As Long
Dim currentNewSheetRow As Long: currentNewSheetRow = 1
Sheets("Summary").Activate
For CurrentRow = 2 To 20000
Dim timesToDuplicate As Integer
timesToDuplicate = CInt(Worksheets("Summary").Range("R" & CurrentRow).Value) 'THE DUPLICATED TIMES 4
Dim i As Integer
For i = 1 To timesToDuplicate
    With Worksheets("Summary")
    .Range("A" & currentNewSheetRow).Offset(1, 0).Value = Worksheets("Summary").Range("H" & CurrentRow).Value 'GET THE OUTCOME1 (ColA)
    End With
    currentNewSheetRow = currentNewSheetRow + 1
    Next i
Next CurrentRow
Application.CutCopyMode = False
Application.ScreenUpdating = True 
End Sub

What I am expecting for is: See the attachment 1
My question is how can I copy paste people's names, the position, and numbers based on the Column A? Thank you in advance!

 

[pbornemeier]

The numbers in your summary sheet do not correspond with the numbers at the intersection of task and name in the provided input form.

This code should produce the output you described:

Option Explicit

Sub FormSummary()

    Dim wks As Worksheet
    Dim lColCount As Long
    Dim lRowCount As Long
    Dim lColActive As Long
    Dim lRowActive As Long
    Dim rngCell As Range
    Dim lNextWriteRow As Long
    
    With Worksheets("Summary")
        .Cells.Clear
        lNextWriteRow = 1
        .Range("A1").Resize(1, 4).Value = Array("Task", "Name", "Score", "Source")
    End With
    
    For Each wks In ThisWorkbook.Worksheets
        With wks
            If InStr(.Name, "FormB") > 0 Then   'wks is a form worksheet
                
                lColCount = .Cells(2, .Columns.Count).End(xlToLeft).Column  'Last Column in Row 2
                lRowCount = .Cells(.Rows.Count, 1).End(xlUp).Row            'Last Row in Column 1
                
                'Examine each Name/Task intersection
                For Each rngCell In wks.Range(.Cells(4, 2), .Cells(lRowCount, lColCount))
                    lColActive = rngCell.Column: lRowActive = rngCell.Row
                    lNextWriteRow = lNextWriteRow + 1
                    
                    'Update Summary Worksheet
                    With Worksheets("Summary")
                        .Cells(lNextWriteRow, 1).Value = wks.Cells(lRowActive, 1).Value 'Task
                        .Cells(lNextWriteRow, 2).Value = wks.Cells(2, lColActive).Value 'Name
                        .Cells(lNextWriteRow, 3).Value = wks.Cells(lRowActive, lColActive).Value 'Score
                        'Added this so you could verify where each data row came from
                        .Cells(lNextWriteRow, 4).Value = wks.Name & "!" & rngCell.Address(False, False)  'Source
                    End With
                Next
            End If
        End With
    Next
    With Worksheets("Summary")
        .Columns.AutoFit
        .Select
    End With
End Sub