Correcting Shape Assigned Macro Links After Copying Worksheet VBA

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 happends 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 from someone who purchased my unlocked  Exporter Template. The Exporter Template allows you to completely automate exporting pre-determined worksheets into various file formats and even allows you to email that file through Microsoft Outlook. All with the click of a button

The problem was, this individual 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 him to 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 an 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

How Do I Modify This To Fit My Specific Needs?

Chances are this post did not give you the exact answer you were looking for. We all have different situations and it's impossible to account for every particular need one might have. That's why I want to share with you: My Guide to Getting the Solution to your Problems FAST! In this article, I explain the best strategies I have come up with over the years to getting quick answers to complex problems in Excel, PowerPoint, VBA, you name it

I highly recommend that you check this guide out before asking me or anyone else in the comments section to solve your specific problem. I can guarantee 9 times out of 10, one of my strategies will get you the answer(s) you are needing faster than it will take me to get back to you with a possible solution. I try my best to help everyone out, but sometimes I don't have time to fit everyone's questions in (there never seem to be quite enough hours in the day!).

I wish you the best of luck and I hope this tutorial gets you heading in the right direction!

Chris "Macro" Newman :)