Fix Subscript out of range VBA

Question

I am try to copy formula and header contained in range "T12:W13" and paste it in the same cell location in all files in a folder. Cop to destination "T12:W13" then drag the formula all the way down close and save the sheet and then open next sheet till all the files in the folder are done.

Sub CopyRange()

Application.ScreenUpdating = False

    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Const strPath As String = "C:\Users\kaii\Downloads\Jan 2022\"
    ChDir strPath
    strExtension = Dir("*.xlsx*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            .Sheets("Monthly").Range("T12:W13").Copy wkbDest.Sheets("XXTOLL_Collector_Invoice_*").Range("T12").Paste
            ActiveCell.AutoFill Range(ActiveCell, ActiveCell.Offset(0, -1).End(xlDown).Offset(0, 1))
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
End Sub

Answer 1

Copy Columns (Headers, Formulas, Last Row) to Worksheets

Option Explicit

Sub CopyColumns()

    ' Source ('ThisWorkook')
    Const sName As String = "Monthly"
    Const sAddress As String = "T12:W13"
    ' Destination (Opening Workbooks)
    Const dFolderPath As String = "C:\Users\kaii\Downloads\Jan 2022\"
    Const dFileExtension As String = ".xlsx"
    Const dFilePattern As String = "*"
    Const dNameLeft As String = "XXTOLL_Collector_Invoice_"
    Const dAddress As String = "T12:W13"
    
    Dim dFileName As String
    dFileName = Dir(dFolderPath & dFilePattern & dFileExtension)
    If Len(dFileName) = 0 Then
        MsgBox "No files found.", vbExclamation
        Exit Sub
    End If
    
    Dim swb As Workbook: Set swb = ThisWorkbook
    Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range(sAddress)
    
    Application.ScreenUpdating = False
    
    Dim dwb As Workbook
    Dim dws As Worksheet
    Dim drg As Range
    Dim dlrCell As Range
    
    Do While Len(dFileName) > 0
        Set dwb = Workbooks.Open(dFolderPath & dFileName)
        For Each dws In dwb.Worksheets
            If InStr(1, dws.Name, dNameLeft, vbTextCompare) = 1 Then ' begins w
                Set drg = dws.Range(dAddress)
                srg.Copy drg
                Set dlrCell = dws.UsedRange _
                    .Find("*", , xlFormulas, , xlByRows, xlPrevious)
                With drg.Resize(1).Offset(1)
                    .Resize(dlrCell.Row - .Row + 1).Formula = .Formula
                End With
            End If
        Next dws
        dwb.Close SaveChanges:=True
        dFileName = Dir
    Loop
        
    Application.ScreenUpdating = True

    MsgBox "Columns copied.", vbInformation

End Sub