Retain Font Formats After Changing An Excel Shape's Formula

Prevent Font Formats Changing While Modifying Excel Shape Formulas

This is a frustration I seem to always face while creating dashboards or graphics for Excel reports. I create a super cool callout graphic to bring attention to an important figure in my data. I have this graphic perfectly formatted and proceed to copy it a couple of times to link some more important figures to these callouts. In my example below, I started with the "Ohio" and linked it to some cells to make it dynamic. I then proceeded to copy it twice to create a callout for the states of Iowa and Maine.

Link Formula to Excel Shape or Textbox

The problem arises when you go and try to adjust the shape or textbox formulas to a link to a different cell address. For some reason, Excel wants to reset the the font format after a formula change. Then the pain begins...you have to go back and reformat each of the graphics (either manually or with the Format Painter button). What a pain in the butt!

Problems Modifying Excel Shape Formulas

A Solution To Prevent This

After running into this issue for quite some time and failing to find any solution on the internet, I did what any VBA coder would do....create a solution from scratch. With the macro solution I drew up, you can select the shape you want to adjust and modify cell address link while maintaining the text formats.

The Magic Trick: The VBA code stores the font formats before the formula gets changed and then re-applies the formats to the shape.

VBA Macro Solution Modifying Excel Shape Formulas

The VBA Macro Solution

Below is the code I came up with and use on a regular basis while creating graphics and callouts that need to display data. All you need to do is copy this code into your Personal Macro workbook and then you can access it whenever you need it (I have this macro placed in my Quick Access Toolbar or QAT also).

Sub LinkShape_RetainFormat()
'PURPOSE: Prevent The Resetting Of Font Format When Changing An Excel Shape's Formula
'SOURCE: www.TheSpreadsheetGuru.com

Dim shp As Shape
Dim LinkCell As Range
Dim FontBold As Boolean
Dim FontItalic As Boolean
Dim FontColor As Long
Dim FontSize As Long
Dim FontUnderline As Long
Dim FontName As String
Dim myAnswer As Variant

'Determine If Selection Is A Shape
  On Error GoTo InvalidSelection
    Set shp = ActiveSheet.Shapes(Selection.Name)
  On Error GoTo 0

'Store Current Font Settings
  With Selection.ShapeRange.TextFrame2.TextRange.Font
    FontBold = .Bold
    FontColor = .Fill.ForeColor
    FontSize = .Size
    FontItalic = .Italic
    FontUnderline = .UnderlineColor
    FontName = .Name
  End With

'Ask User For New Cell To Link To
  On Error GoTo UserCancelled
    Set LinkCell = Application.InputBox("Select a single cell to link to", Type:=8)
  On Error GoTo 0
  
'Change Shape's Cell Link
  If LinkCell.Parent.Name = ActiveSheet.Name Then
    Selection.Formula = "=" & LinkCell.Cells(1, 1).Address
  Else
    Selection.Formula = "='" & LinkCell.Parent.Name & "'!" & LinkCell.Cells(1, 1).Address
  End If

'Restore Original Font Settings
  With Selection.ShapeRange.TextFrame2.TextRange.Font
    .Bold = FontBold
    .Fill.ForeColor.RGB = FontColor
    .Size = FontSize
    .Italic = FontItalic
    .UnderlineColor = FontUnderline
    .Name = FontName
  End With

'Scroll Back to Selected Shape
  myAnswer = MsgBox("Scroll back to graphic location?", vbYesNo)
  
  If myAnswer = vbYes Then
    ActiveWindow.ScrollColumn = Selection.TopLeftCell.Column
    ActiveWindow.ScrollRow = Selection.TopLeftCell.Row
  End If
  
Exit Sub

'ERROR HANDLERS
InvalidSelection:
  MsgBox "Please select a shape object before running this code"
  Exit Sub

UserCancelled:
  Exit Sub

End Sub

[Optional] Auto-Populate Current Linked Cell

Below is the same macro as above but with one modification that I found to be useful. It auto-populates the input box with the current formula address. This can be useful if you data is located far away from where your graphic resides. This is because the input box will automatically navigate you to where the cell location is visually. Try it out!

Sub LinkShape_RetainFormat2()
'PURPOSE: Prevent The Resetting Of Font Format When Changing An Excel Shape's Formula
'SOURCE: www.TheSpreadsheetGuru.com

Dim shp As Shape
Dim LinkCell As Range
Dim FontBold As Boolean
Dim FontItalic As Boolean
Dim FontColor As Long
Dim FontSize As Long
Dim FontUnderline As Long
Dim FontName As String
Dim myAnswer As Variant

'Determine If Selection Is A Shape
  On Error GoTo InvalidSelection
    Set shp = ActiveSheet.Shapes(Selection.Name)
  On Error GoTo 0

'Store Current Font Settings
  With Selection.ShapeRange.TextFrame2.TextRange.Font
    FontBold = .Bold
    FontColor = .Fill.ForeColor
    FontSize = .Size
    FontItalic = .Italic
    FontUnderline = .UnderlineColor
    FontName = .Name
  End With

'Ask User For New Cell To Link To (Default To Current Formula)
  On Error GoTo UserCancelled
    Set LinkCell = Application.InputBox("Select a single cell to link to", _
     Type:=8, Default:=Selection.Formula)
  On Error GoTo 0

'Change Shape's Cell Link
  If LinkCell.Parent.Name = ActiveSheet.Name Then
    Selection.Formula = "=" & LinkCell.Cells(1, 1).Address
  Else
    Selection.Formula = "='" & LinkCell.Parent.Name & "'!" & LinkCell.Cells(1, 1).Address
  End If

'Restore Original Font Settings
  With Selection.ShapeRange.TextFrame2.TextRange.Font
    .Bold = FontBold
    .Fill.ForeColor.RGB = FontColor
    .Size = FontSize
    .Italic = FontItalic
    .UnderlineColor = FontUnderline
    .Name = FontName
  End With

'Scroll Back to Selected Shape
  myAnswer = MsgBox("Scroll back to graphic location?", vbYesNo)
  
  If myAnswer = vbYes Then
    ActiveWindow.ScrollColumn = Selection.TopLeftCell.Column
    ActiveWindow.ScrollRow = Selection.TopLeftCell.Row
  End If

Exit Sub

'ERROR HANDLERS
InvalidSelection:
  MsgBox "Please select a shape object before running this code"
  Exit Sub

UserCancelled:
  Exit Sub

End Sub

Download An Example File

If you need a little head start or are not comfortable with VBA quite yet, I have put together a great little example Excel file with some of the examples covered in this article.

As always, in order to download this or any example file from this website, you will need to be a subscriber of my free tips newsletter.  If you click the green button below you can easily sign up and you will be emailed the password to get into the subscribers-only area of this website.

 
     Already Subscribed? Click HERE to log-in to the "Example Files" section

     Already Subscribed? Click HERE to log-in to the "Example Files" section

 

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 :)