Big challenge: Use arrays to copy multiple columns, paste in different worksheets, and repeat for many data points!

[Jlascu]

Hello,
I have a problem that is challenging, and not sure how to solve it ..

Here is the overall logic:
1. Model calculates a stream of data (for 1 datapoint) and pastes it into 16 different columns
2. The data from these 16 columns is pasted, as a row, into 16 different worksheets
3. Repeat again for the following data point (# of data points may vary)

Problem:
It is painfully slow, takes over 1hr for 1,500 data points with the code below.
Tried using arrays but the problem is the same, the code is not faster.
A different approach I tried was to save all the stream data of the columns for all data points, and then do one big pasting in each worksheet (but here I'm stuck)

Pasting my code below, but (as you can see), not a professional coder ...
Any help is greatly appreciated

'With arrays
Sub Macro2()

Dim sActiveWorkbookName As String

Dim StartTime As Double
Dim MinutesElapsed As String

    Dim Fnd         As Range        ' target to find
    Dim Arr         As Variant      ' values in found row
    Dim Arr2         As Variant      ' values in found row
    Dim R           As Long

    'Remember time when macro starts
    StartTime = Timer
    'Get worksheet name & number of columns with consolidated data to copy
    sActiveWorkbookName = ActiveWorkbook.Name
    iNoColumnsCopy = 15
    
    'Clean sheets where data is received
    Sheets(Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15")).Select
    Sheets("1").Activate: Range("H8").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    
    Sheets("Engine").Activate
    
    'TEST
    Application.ScreenUpdating = False

    
    Set wb = Workbooks(sActiveWorkbookName)
    Set wsQD = wb.Sheets("Engine")
    Set wsPT = wb.Sheets("1")

    'Get number of records
    Set rc = wsQD.Cells.Find(What:="# of Assets", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
    False, SearchFormat:=False)
    With wsQD
        iNoRecords = .Range(rc.Address).Offset(0, 2).Value
    End With
        
    'Get initial paste range
    Set ra = wsPT.Cells.Find(What:="BOP", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
    False, SearchFormat:=False)
    
    For a = 1 To iNoRecords
    
        'Change record
        With wsQD
            .Range(rc.Address).Offset(-1, 2) = a
        End With
    
        For b = 1 To iNoColumnsCopy
    
        Select Case b
            Case 1: sCopylabel = "GCCpy": sSheetPasteValues = "1"           'Gross Collections
            Case 2: sCopylabel = "LegalPCpy": sSheetPasteValues = "2"       'Legal Program
            Case 3: sCopylabel = "3rdPCCpy": sSheetPasteValues = "3"        'Third Party Agency Commissions
            Case 4: sCopylabel = "ELCommCpy": sSheetPasteValues = "4"       'External Lawyer Commisions
            Case 5: sCopylabel = "REAppCpy": sSheetPasteValues = "5"        'Collateral Appraisals
            Case 6: sCopylabel = "REInsCpy": sSheetPasteValues = "6"        'Property Insurance
            Case 7: sCopylabel = "DeedCpy": sSheetPasteValues = "7"         'Deed Transfers
            Case 8: sCopylabel = "SvcFFCpy": sSheetPasteValues = "8"        'Servicing Fixed Fee
            Case 9: sCopylabel = "REAdmCpy": sSheetPasteValues = "9"        'RE Admin fees
            Case 10: sCopylabel = "SvcSFCpy": sSheetPasteValues = "10"      'Servicing Success Fee
            Case 11: sCopylabel = "SvcPLCpy": sSheetPasteValues = "11"      'Servicing Performing
            Case 12: sCopylabel = "BrkrCpy": sSheetPasteValues = "12"       'REO Brokers
            Case 13: sCopylabel = "DlLvExCpy": sSheetPasteValues = "13"     'Deal Level
            Case 14: sCopylabel = "NotCpy": sSheetPasteValues = "14"        'Notification
            Case 15: sCopylabel = "OtherCpy": sSheetPasteValues = "15"      'Other
            Case 16: sCopylabel = "TxCpy": sSheetPasteValues = "16"         'Income Taxes
        End Select
    
        'Get columns to copy
        Set rb = wsQD.Cells.Find(What:=sCopylabel, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
            'Error hadnler: in case no header is found, ends routine
        If rb Is Nothing Then
            MsgBox ("Not found")
                Exit Sub
        Else
                'MsgBox (rb.Address)
        End If

        'Put data in array
        With wsQD
            'Get start & end to copy
            iCopyCol1 = .Range(rb.Address).Column: iCopyCol2 = .Range(rb.Address).Offset(28, 0).End(xlDown).Row '28 is the row to start copying
            sRangeSource = .Range(.Cells(28, iCopyCol1), .Cells(iCopyCol2, iCopyCol1)).Address
            Arr = .Range(sRangeSource)
        End With
    
        'Paste in data capture sheets
        Set wsPT = wb.Sheets(sSheetPasteValues)
        With wsPT
            iFirstRow = .Range(ra.Address).Row + a: iFirstCol = .Range(ra.Address).Column + 7 '28 is the row to start copying
            sRangePivot = .Range(.Cells(iFirstRow, iFirstCol), .Cells(iFirstRow, iCopyCol2 - 28 - iFirstCol)).Address
            .Range(sRangePivot).Value = Application.Transpose(Arr)
        End With
    
        Next
    
    Next
    
    'Determine how many seconds code took to run
    MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
    
    'Notify user in seconds
    MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation
        
    'Time Stamp
    With wsQD
        .Range(rc.Address).Offset(-2, 5) = MinutesElapsed
    End With
    
    'TEST
    Application.ScreenUpdating = True
              
End Sub