Adding in dynamically scaling shapes to existing code

Hello all,

I am trying to expand upon my current code (developed with much help from the forum already) to increase the tracking capability of the workbook it is applied to.

In the attached example workbook, you will see a "Before" and "After" look that I am trying to achieve.

The "Before" look generates shapes to overlay key words that match the shape's name - this is used as somewhat of a scheduling tool and works well for my purposes.

What I am now trying to achieve is a scaling rectangular shape that will fill the void in between my Start and Finish dates, that will be dynamic. I'm not sure of where to start or the best way to approach this, so help is appreciated.

Working preliminary code (also in sample workbook):

Option Explicit

'Private Sub Worksheet_Calculate()

Dim myCell As Range 'Calls the Named Ranges needed for the code to run
Dim mySel As Range
Dim myR As Range 'Sets dimension to center pictures within cell
Dim myS As Shape


Set mySel = Selection

With Application
   .ScreenUpdating = False

On Error Resume Next 'Checks first to see if a cell within the named range is blank, skips if it is, and calls the appropriate image if not
   For Each myCell In Range("KeyCells")
         If myCell <> "" Then
                 ActiveSheet.Shapes(myCell.Address & "Final").Delete 'Deletes old image and replaces it with the called new one
                 ActiveSheet.Shapes(myCell.Value).Select
                 Selection.Copy
                 myCell.Offset(0, 0).Select
                 ActiveSheet.Paste
                 Selection.Name = myCell.Address & "Final"
                 Selection.ShapeRange.ZOrder msoSendToBack
                 With Selection 'Centers pictures within cell
                 Set myR = .TopLeftCell
                 .Left = myR.Left + (myR.Width - .Width) / 2
                 .Top = myR.Top + (myR.Height - .Height) / 2
                 End With
          Else: ActiveSheet.Shapes(myCell.Address & "Final").Delete
          GoTo Skip
    End If
Skip:
Next myCell
mySel.Select

   .ScreenUpdating = True

End With

End Sub