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, 6).Value = Array("lX", "lY", "File", ".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.xlsm"
'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
'Add formulas referencing corresponding cells in the Master to each cell of each named range in the copy
' Comment out next line if you do not want the formulas in each copy's named range cells
MakeNamedRangesCellsReferenceMaster
'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) = aryCopyNames(lX)
.Worksheets("Journal_PAB").Cells(lNextWriteRow, 4) = "'" & Workbooks(sCopyName).Names(lY).Name
.Worksheets("Journal_PAB").Cells(lNextWriteRow, 5) = "'" & 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, 6) = "'" & 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
Worksheets("Journal_PAB").UsedRange.Columns.AutoFit
End_Sub:
Application.AutomationSecurity = secAutomation 'Restore ThisWorkbook security setting
Application.StatusBar = False
End Sub
Sub MakeNamedRangesCellsReferenceMaster()
'The data validation for each named range cell in the copy will be removed since it is not compatible with formulas
Dim lCellCount As Long
Dim lRangeCount As Long
Dim nm As Name
Dim rngCell As Range
For Each nm In ActiveWorkbook.Names
For Each rngCell In nm.RefersToRange
rngCell.Validation.Delete
rngCell.FormulaR1C1 = "='[Master.xlsm]" & rngCell.Worksheet.Name & "'!" & rngCell.Address(, , xlR1C1)
Next
Next
End Sub
Sub Document_ListActiveWorkbookNamedRangesOnAWorksheet()
Dim lX As Long
'Initialize Documentation Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Document_NamedRanges").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Worksheets.Add(Before:=Sheets(1)).Name = "Document_NamedRanges"
With Worksheets("Document_NamedRanges")
.Range("A1").Resize(1, 5).Value = Array("Name", "RefersToR1C1", "RefersTo", "Value", "Comment")
'Examine each named range
For lX = 1 To ActiveWorkbook.Names.Count
With ActiveWorkbook.Names(lX)
Worksheets("Document_NamedRanges").Cells(lX + 1, 1).Value = .Name
Worksheets("Document_NamedRanges").Cells(lX + 1, 2).Value = "'" & .RefersToR1C1
Worksheets("Document_NamedRanges").Cells(lX + 1, 3).Value = "'" & .RefersTo
Worksheets("Document_NamedRanges").Cells(lX + 1, 4).Value = .Value
Worksheets("Document_NamedRanges").Cells(lX + 1, 5).Value = .Comment
Debug.Print .Name, .RefersTo
End With
Next
.UsedRange.Columns.AutoFit
End With
End Sub
Sub CountCellsInNamedRanges()
Dim lCellCount As Long
Dim lRangeCount As Long
Dim nm As Name
For Each nm In ActiveWorkbook.Names
lRangeCount = lRangeCount + 1
lCellCount = lCellCount + nm.RefersToRange.Cells.Count
Next
Debug.Print lRangeCount, lCellCount
End Sub