Option Explicit
Sub CreateCopiesWithNamedRangesReferencingMaster()
'Create a new workbook named Copier.xlsm, add a standard module and put this code in it.
'Save Copier.xlsm in the same directory as the Master file. Copies will be created in that directory
Dim aryCopyNames As Variant
Dim lX As Long, lY As Long
Dim sCopyName As String
Dim secAutomation As MsoAutomationSecurity
Dim sExtension As String
Dim sMasterFileName As String
Dim lNameCount As Long
Dim lCopyCount As Long
Dim lNextWriteRow As Long
'Create a Journal worksheet in thisworkbook
With ThisWorkbook
On Error Resume Next
Application.DisplayAlerts = False
.Worksheets("Journal_PAB").Delete
Application.DisplayAlerts = True
On Error GoTo 0
.Worksheets.Add(Before:=.Sheets(1)).Name = "Journal_PAB"
.Worksheets("Journal_PAB").Range("A1").Resize(1, 5).Value = Array("lX", "lY", ".Name", "Original .RefersTo", "Updated .RefersTo")
End With
lNextWriteRow = 1
'Modify the next line to contain the name of the Master workbook, be sure to include the extension
sMasterFileName = "Master.xlsx"
'An example for the above line would be sMasterFileName = "Master.xlsx"
'Modify next line to contain names of each copy. extension will be copied from the extension in sMasterFileName
aryCopyNames = Array("CopyA", "CopyB")
'An example for the above line would be aryCopyNames = Array("CopyA", "CopyB", "CopyC")
secAutomation = Application.AutomationSecurity 'Save ThisWorkbook security setting
Application.AutomationSecurity = msoAutomationSecurityForceDisable 'Disable macros when opening file
sExtension = Mid(sMasterFileName, InStrRev(sMasterFileName, "."))
'Open the master file
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & sMasterFileName
For lX = LBound(aryCopyNames) To UBound(aryCopyNames)
If UCase(Right(aryCopyNames(lX), Len(sExtension))) <> UCase(sExtension) Then
sCopyName = aryCopyNames(lX) & sExtension
Else
sCopyName = aryCopyNames(lX)
End If
'Save a copy of the master file
Workbooks(sMasterFileName).SaveCopyAs Filename:=ThisWorkbook.Path & "\" & sCopyName
'Open the copy
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & sCopyName
'Update named ranges in the copy
lNameCount = Workbooks(sMasterFileName).Names.Count
lCopyCount = UBound(aryCopyNames) + 1
For lY = 1 To lNameCount
With Workbooks(sCopyName).Names(lY)
'Update journal with value about to be changed
lNextWriteRow = lNextWriteRow + 1
With ThisWorkbook
.Worksheets("Journal_PAB").Cells(lNextWriteRow, 1) = lX
.Worksheets("Journal_PAB").Cells(lNextWriteRow, 2) = lY
.Worksheets("Journal_PAB").Cells(lNextWriteRow, 3) = "'" & Workbooks(sCopyName).Names(lY).Name
.Worksheets("Journal_PAB").Cells(lNextWriteRow, 4) = "'" & Workbooks(sCopyName).Names(lY).RefersTo
End With
'.RefersTo = "=[" & sMasterFileName & "]" & Mid(.RefersTo, 2) 'Original
If InStr(.RefersTo, "'") > 0 Then
'worksheet name contains at least 1 space (and therefore contains a single quote)
.RefersTo = "='[" & sMasterFileName & "]" & Mid(.RefersTo, 3)
Else
'Named range does not have a space
.RefersTo = "=[" & sMasterFileName & "]" & Mid(.RefersTo, 2) 'Original (no space in worksheet name)
End If
Application.StatusBar = "Copy " & lX + 1 & " of " & lCopyCount & ": Updated named range " & lY & " of " & lNameCount & " " & .RefersTo
DoEvents
With ThisWorkbook
.Worksheets("Journal_PAB").Cells(lNextWriteRow, 5) = "'" & Workbooks(sCopyName).Names(lY).RefersTo
End With
End With
Next
'Save and close the copy
Workbooks(sCopyName).Save
Workbooks(sCopyName).Close
Next
'Close the master file
Workbooks(sMasterFileName).Close
End_Sub:
Application.AutomationSecurity = secAutomation 'Restore ThisWorkbook security setting
Application.StatusBar = False
End Sub