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
        Else
        MsgBox "The Named Range """ & rngName.Value & """ Does Not Exist" & vbLf & vbLf & "Continue?", vbYesNo + vbExclamation
        If response = vbNo Then
        wbError.Add
        rngNames.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
        End If
        End If
    Next rngName
End Sub