vba - copia a pasta de trabalho 300 vezes depois que o usuário seleciona a pasta

Question

Veja o código abaixo, eu quero quando o usuário navega para a pasta de modelos, a primeira pasta de trabalho do Excel nessa pasta criar uma cópia dele 300 vezes.

Option Explicit

Sub Button4_Click()

    Dim desktop As Variant
    Dim Files   As Object
    Dim Folder  As Variant
    Dim oShell  As Object
    Dim Tmplts  As Variant      ' Templates folder
    Dim wsLocal As Worksheet
    Dim wsGroup As Worksheet
    Dim wb      As Object

        ' Check Box 3 "Select All" must be checked to run the macro.
        If ActiveSheet.Shapes("Check Box 3").ControlFormat.Value = xlOff Then Exit Sub

        Application.ScreenUpdating = False
        Application.EnableEvents = False

        ' Prompt user to locate the Templates folder.
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = True Then
                Tmplts = .SelectedItems(1)
            Else
                Exit Sub
            End If
        End With
        Set oShell = CreateObject("Shell.Application")
        Set desktop = oShell.Namespace(0)




            ' Create the Output folder on the User's Desktop if it does not exist.
            Set Folder = desktop.ParseName("Output")
                If Folder Is Nothing Then
                    desktop.NewFolder "Output"
                    Set Folder = desktop.ParseName("Output")
                End If

            Set Files = oShell.Namespace(Tmplts).Items
                Files.Filter 64, "*.xlsm"

                For Each wb In Files
                    Set wb = Workbooks.Open(Filename:=wb.Path, UpdateLinks:=False)

                    Call BreakLinks(wb)

                    On Error Resume Next
                        Set wsLocal = wb.Worksheets("RVP Local GAAP")
                        Set wsGroup = wb.Worksheets("RVP Group GAAP")
                        'unprotect workbook
                        wsLocal.Unprotect Password:="KqtgH5rn9v"
                        wsGroup.Unprotect Password:="KqtgH5rn9v"
                    On Error GoTo 0

                    ' Check that both worksheets exist before updating.
                    If Not wsLocal Is Nothing And Not wsGroup Is Nothing Then
                    Call ProcessNamedRanges(wb)
                        'lock the workbook
                        wsLocal.Protect Password:="KqtgH5rn9v"
                        wsGroup.Protect Password:="KqtgH5rn9v"

                        ''MsgBox "Ranges have been updated sucessfully."

                        ' Save the workbook to the folder and close.
                        On Error Resume Next
                          wb.SaveAs Filename:=Folder.Path & "\" & wb.Name
                          ActiveWorkbook.Close True
                        On Error GoTo 0
                    End If
                Next wb
        Application.ScreenUpdating = True
        Application.EnableEvents = True
End Sub
Sub ProcessNamedRanges(ByRef wb As Workbook)

    Dim dstRng      As Range
    Dim rng         As Range
    Dim rngName     As Range
    Dim rngNames    As Range
    Dim wks         As Worksheet
'    Dim response    As Integer
'    Dim wbError As Workbook
'    Dim wserror As Worksheet
'    Dim desktop As Variant
'    Dim Files   As Object
'    Dim Folder  As Variant

'    Set wbError = Workbooks.Add
'    Set wserror = wbError.Sheets("Sheet1")

    Set wks = ThisWorkbook.Sheets("Output - Flat")

 ''if workbook name contains ted id then return back all the values for ted id
 If wb.Name Like "Ted ID-*" = wks("tedID") Then


     ' Exit if there are no named ranges listed.
    If wks.Range("G4") = "" Then Exit Sub

    Set rngNames = wks.Range("G4").CurrentRegion
    Set rngNames = Intersect(rngNames.Offset(1, 0), rngNames.Columns(3))

     'Loop through all the values in NamedRange
    For Each rngName In rngNames
         ' Verify the Named Range exists.
        On Error Resume Next
        Set dstRng = wb.Names(rngName.Text).RefersToRange
        If Err = 0 Then
             'Copy the report balance to the Template worksheet in column "G".
            dstRng.Value = rngName.Offset(0, 1).Value
'        response = MsgBox("The Named Range """ & rngName.Value & """ Does Not Exist" & vbLf & vbLf & "Continue?", vbYesNo + vbExclamation)
'        If response = vbNo Then
'        Set wbError = Workbooks.Add
'        rngName.Value.Copy
'        wbError.wserror.rngName.PasteSpecial Paste:=xlPasteValues
'        wbError.SaveAs Filename:=Folder.Path & "\" & "Audit Trail.xlsm"
'        ActiveWorkbook.Close
'        End If
'        If response = vbYes Then
'        ActiveWorkbook.Activate
'        ActiveWorkbook.Close
        End If
        On Error GoTo 0
    Next rngName
End Sub

Sub BreakLinks(ByRef wb As Workbook)

    Dim i       As Long
    Dim wbLinks As Variant

        wbLinks = wb.LinkSources(xlExcelLinks)

        If Not IsEmpty(wbLinks) Then
            For i = 1 To UBound(wbLinks)
                ActiveWorkbook.BreakLink wbLinks(i), xlLinkTypeExcelLinks
            Next i
        End If
End Sub