×

Correcting Shape Assigned Macro Links After Copying Worksheet VBA

By Chris Newman •  Updated: 03/12/16 •  8 min read
Fix Assigned Macro Copy Workbook Name Excel Spreadsheets VBA

Transferring VBA Through Worksheet Objects

The easiest way to copy over VBA code while copying your worksheets into a new workbook is to store your VBA macros within the worksheet itself instead of the typical Modules that most people use. While it is possible to copy Modules from one workbook to another, it adds another layer of VBA coding that is much more of a hassle than storing your code within a Worksheet Object.

The one problem with this, however, arises when you have macros assigned to be triggered by on-sheet buttons (ie shapes). What happens when you copy a worksheet, is the macro link still points back to the original workbook and not the new one. Here is an example showing what happened when I copied a worksheet with VBA code stored in it from Book1 into Book2:

an example showing what happened when I copied a worksheet with VBA code stored in it from Book1 into Book2

As you can see in the above screenshot, the macro name is still referencing Book1 instead of the name of the workbook (Book2) that I am actually in. Having to go into each Macro-assigned shape button’s settings and fixing the links (by removing the workbook reference) can be a real pain, especially if you have a lot of buttons to fix!

So how can you prevent this from happening? Well, the answer is YOU CAN’T prevent it from happening, but you CAN use VBA to fix all your macro links once you’ve copied over your worksheets. Simply run the following macro while the worksheet is active and it will go through all your shapes and fix any links that have references to a workbook.

Sub ShapeMacroLink_RemoveWorkbookRef()
'PURPOSE: Remove an external workbook reference from all shapes triggering macros
'Source: www.TheSpreadsheetGuru.com

Dim shp As Shape
Dim MacroLink As String
Dim SplitLink As Variant
Dim NewLink As String

'Loop through each shape in worksheet
  For Each shp In ActiveSheet.Shapes
  
    'Grab current macro link (if available)
      MacroLink = shp.OnAction
    
    'Determine if shape was linking to a macro
      If MacroLink <> "" And InStr(MacroLink, "!") <> 0 Then
        'Split Macro Link at the exclaimation mark (store in Array)
          SplitLink = Split(MacroLink, "!")
        
        'Pull text occurring after exclaimation mark
          NewLink = SplitLink(1)
        
        'Remove any straggling apostrophes from workbook name
            If Right(NewLink, 1) = "'" Then
              NewLink = Left(NewLink, Len(NewLink) - 1)
            End If
        
        'Apply New Link
          shp.OnAction = NewLink
      End If
  
  Next shp
   
End Sub

Fixing Every Worksheet In The Workbook At Once

If you are copying multiple worksheets that house buttons assigned to macro code, you can use the following VBA code to loop through all worksheet tabs in the ActiveWorkbook.

Sub ShapeMacroLinkAll_RemoveWorkbookRef()
'PURPOSE: Remove any external workbook references from all shapes triggering macros in Activeworkbook
'Source: www.TheSpreadsheetGuru.com

Dim shp As Shape
Dim sht As Worksheet
Dim MacroLink As String
Dim SplitLink As Variant
Dim NewLink As String

'Loop through each shape in each worksheet
  For Each sht In ActiveWorkbook.Worksheets
    For Each shp In sht.Shapes
    
      'Grab current macro link (if available)
        MacroLink = shp.OnAction
      
      'Determine if shape was linking to a macro
        If MacroLink <> "" And InStr(MacroLink, "!") <> 0 Then
          'Split Macro Link at the exclaimation mark (store in Array)
            SplitLink = Split(MacroLink, "!")
          
          'Pull text occurring after exclaimation mark
            NewLink = SplitLink(1)
          
          'Remove any straggling apostrophes from workbook name
            If Right(NewLink, 1) = "'" Then
              NewLink = Left(NewLink, Len(NewLink) - 1)
            End If
          
          'Apply New Link
            shp.OnAction = NewLink
        End If
    
    Next shp
  Next sht
  
End Sub

Fully Automating This Process

This post was inspired by an email I received today. His problem was that he needed to export some VBA capabilities along with his worksheets and he was running into the issue of having to re-link all his macro buttons prior to emailing the file as an attachment.  

In order to fix this, I recommended he add the following subroutine which accepts a workbook variable to apply the macro link fixes as part of the VBA automation process. This removes the step of having to go back and manually run a second macro to fix all your macro button links.

In the following code, I have one macro that copies a workbook and then runs (calls) a second macro to clean up all the macro button links. This is probably the solution you are most likely going to want to incorporate if you are automating your worksheet duplication.

Sub CopyWorkbook()
'PURPOSE: Copy the active workbook into a new workbook
'Source: www.TheSpreadsheetGuru.com

Dim wb As Workbook

'Make a copy of active workbook
  ActiveWorkbook.Worksheets.Copy

'Store new workbook into a variable
  Set wb = ActiveWorkbook

'Fix any macro assigned buttons
  Call FixMacroLinks(wb)

End Sub

Sub FixMacroLinks(myWorkbook As Workbook)
'PURPOSE: Localize any shape macro links (needs a target workbook to work)
'Source: www.TheSpreadsheetGuru.com

Dim shp As Shape
Dim sht As Worksheet
Dim MacroLink As String
Dim SplitLink As Variant
Dim NewLink As String

'Loop through each shape in each worksheet
  For Each sht In myWorkbook.Worksheets
    For Each shp In sht.Shapes
    
      'Grab current macro link (if available)
        MacroLink = shp.OnAction
      
      'Determine if shape was linking to a macro
        If MacroLink <> "" And InStr(MacroLink, "!") <> 0 Then
          'Split Macro Link at the exclaimation mark (store in Array)
            SplitLink = Split(MacroLink, "!")
          
          'Pull text occurring after exclaimation mark
            NewLink = SplitLink(1)
          
          'Remove any straggling apostrophes from workbook name
            If Right(NewLink, 1) = "'" Then
              NewLink = Left(NewLink, Len(NewLink) - 1)
            End If
          
          'Apply New Link
            shp.OnAction = NewLink
        End If
    
    Next shp
  Next sht
  
End Sub

Keep Learning

Chris Newman

Chris Newman

Chris is a finance professional and Excel MVP recognized by Microsoft since 2016. With his expertise, he founded TheSpreadsheetGuru blog to help fellow Excel users, where he shares his vast creative solutions & expertise. In addition, he has developed over 7 widely-used Excel Add-ins that have been embraced by individuals and companies worldwide.

[FREE Training] 10 Amazing Excel Efficiency Tricks. Why Don't People Know These?!

X