Create copy workbook with cell referencing to original

[Faith]

Hello,

At my work we are using Excel as a CMS to produce SQL scripts for insertion into a database. The data is then turned into mobile web pages. This involves multiple workbooks - 1 for each main page with the sub-pages as extra worksheets in the book.

Much of the data is duplicated so we have created master workbooks then copied them and laboriously referenced the relevant cells back to the original. That way if any data in the master is changed, all copies will change simultaneously.

This is obviously not the most efficient way of publishing web pages but we are stuck with it for now. So I am wondering if it is possible to write a VBA code to create a copy of the master and then reference all required tables in the worksheets automatically? The tables are all named ranges.

Any help is really appreciated.

 

[Faith]

Name <tbody> </tbody>	RefersToR1C1 <tbody> </tbody>	RefersTo <tbody> </tbody>
CS_LinkType_LOV <tbody> </tbody>	=Lookups!R2C6:R50C6 <tbody> </tbody>	=Lookups!$F$2:$F$50 <tbody> </tbody>
LOV_AlternatePage <tbody> </tbody>	=Lookups!R2C49:R3C49 <tbody> </tbody>	=Lookups!$AW$2:$AW$3 <tbody> </tbody>
LOV_Campaign <tbody> </tbody>	=Lookups!R2C3:R50C3 <tbody> </tbody>	=Lookups!$C$2:$C$50 <tbody> </tbody>
LOV_Community <tbody> </tbody>	=Lookups!R2C5:R50C5 <tbody> </tbody>	=Lookups!$E$2:$E$50 <tbody> </tbody>
LOV_Content <tbody> </tbody>	=Lookups!R2C1:R50C1 <tbody> </tbody>	=Lookups!$A$2:$A$50 <tbody> </tbody>
LOV_ContentSection <tbody> </tbody>	=Lookups!R2C8:R50C8 <tbody> </tbody>	=Lookups!$H$2:$H$50 <tbody> </tbody>
LOV_CopyTypeCode <tbody> </tbody>	=Lookups!R2C18:R50C18 <tbody> </tbody>	=Lookups!$R$2:$R$50 <tbody> </tbody>
LOV_Creative <tbody> </tbody>	=Creatives!R6C2:R30C2 <tbody> </tbody>	=Creatives!$B$6:$B$30 <tbody> </tbody>
LOV_CreativeCode <tbody> </tbody>	=Lookups!R2C12:R50C12 <tbody> </tbody>	=Lookups!$L$2:$L$50 <tbody> </tbody>
LOV_CreativeTypeCode <tbody> </tbody>	=Lookups!R2C16:R49C16 <tbody> </tbody>	=Lookups!$P$2:$P$49 <tbody> </tbody>

<tbody>
</tbody>

Sorry the table went a bit weird but hopefully you get it. The copy and master are identical.

I found the Immediate window and ran the macro again - it worked!

ETA: I didn't include the Value or Comment columns as I didn't think they were relevant. But let me know if you want to see them.

 

[pbornemeier]

I originally designed the code to be added to the Master workbook and did not modify all that I needed to when I changed it to be in the Copier.xlsm file.

Here is a revised version to replace the sub in Copier.xlsm. Let me know how it works for you.

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
    
    '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("CopyAA", "CopyBB", "CopyCC")
    '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
        For lY = 1 To Workbooks(sMasterFileName).Names.Count
            With Workbooks(sCopyName).Names(lY)
                .RefersTo = "=[" & sMasterFileName & "]" & Mid(.RefersTo, 2)
            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
    
End Sub

I regret that the previous versions that were not properly coded.

 

[Faith]

Hi Phil

Thanks for being so patient, no worries!

I tried this and it creates the new workbook but I am getting the following error:

Runtime error 1004
The name that you entered is not valid.
Reasons for this can include:
- The name does not begin with a letter or an underscore
- The name contains a space or other invalid characters
- The name conflicts with an Excel built-in name or the name of another object in the workbook

When I click Debug it goes to the line:
.RefersTo = "=[" & sMasterFileName & "]" & Mid(.RefersTo, 2)

That's with the following names in the macro:
'Modify the next line to contain the name of the Master workbook, be sure to include the extension
sMasterFileName = "Rainbow.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("Flowers")
'An example for the above line would be aryCopyNames = Array("CopyA", "CopyB", "CopyC")

I used the simplest names that I could be sure weren't being used anywhere else. The copy is created fine and the named ranges are there but no referencing.

There is a lot of other VBA code in the master which I thought might be messing it up so tried making a new xlsm file called Unicorn with just one named range. Then I ran the macro, didn't get the error but the named range was not copied correctly. The box I made to show where the range was appeared in the new sheet but had lost the name.

So altogether a bit confusing!

 

[pbornemeier]

Faith,
I sent you a private message on this board. Please send a copy of your master workbook to the email listed there, and I will figure out the probblem.
Phil

 

[Faith]

Hi Phil

I emailed you the other day - maybe it went in your spam? I've just sent it again. Let me know if you don't receive it.

Thanks
Faith

 

[pbornemeier]

Faith,

The workbook I tested my code on did not have any worksheets with spaces in their names. The code failed when it got to worksheets with names with spaces. I modified the code to check for this and update the named ranges in this case in the correct way. I also added a progress indicator that will appear in the lower left corner of the screen.

Please let me know how the new version works for you. Or if you need other changes.

Phil

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
    
    '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
        
        '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)
                '.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
            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

 

[Faith]

Hi Phil

Just tried running it again and the same error is coming up. It still doesn't like the line:

.RefersTo = "=[" & sMasterFileName & "]" & Mid(.RefersTo, 2) 'Original (no space in worksheet name)

Any thoughts?

Faith

 

[pbornemeier]

Faith,

That is truly odd. I ran the updated code against the copy of the Master that you sent and it created duplicate workbooks with updated named ranges.

Run it again.
When the debug error comes up open the immediate window in the VB Editor (Ctrl+G) and type into it:
? "=[" & sMasterFileName & "]" & Mid(.RefersTo, 2)

This will cause that value to be evaluated and it will be displayed below the line you typed in.

Post the value that is displayed.

Also post what is displayed in the lower left corner of the Excel window - should be something lile Copy 1 of 3: Updated Named Range 23 of 157 (then the named range .RefersTo text)

Phil

 

[Faith]

I created a new Copier sheet, copied your code above again and used the blank master I sent you.

The same debug error came up with the following evaluation in the immediate window:

? "=[" & sMasterFileName & "]" & Mid(.RefersTo, 2)
=[Master.xlsm]#NAME?

Don't know if it's relevant but if I run the macro again while the Master and CopyA worksheet are open, it brings up the same 1004 error but when I debug it goes to a different line:

Workbooks(sMasterFileName).SaveCopyAs Filename:=ThisWorkbook.Path & "\" & sCopyName

I tried putting that line in the immediate window with the ? in front but it just comes up with an error message box that says Compile Error: Expected: Expression.

I didn't see anything in the lower left corner. I have a properties box but it's empty apart from the Module name. Can you give more details on how I can display what you're looking for?

 

[pbornemeier]

The error occuring on this line Workbooks(sMasterFileName).SaveCopyAs Filename:=ThisWorkbook.Path & "\" & sCopyName

while the Master and CopyA worksheet are open is happening because the program is trying to save a copy with the same name as an already open file

The lower left corner I am talking about is on the "normal" Excel screen. The status bar is on the bottom of the display under the worksheet cells.

I can't get to your Master copy now, I will do that tonight.

This code has been modified to make journal entries on a worksheet in the copier workbook as the names are modified. Please send me the last few lines on that worksheet when the debug error comes up

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