vba - copy workbook 300 times once user selects folder

[carissa7]

See code below, I want when the user browses for the template, the first excel workbook in that folder create copy of it 300 times in that same folder, then the loop that is currently there will loop through all those excel workbooks in that folder.


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")


' 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