Assigning Hyperlink Tooltips to ShapeRange?

[Thomas2016]

I'm working on a chloropleth map (U.S. county heatmap), and have run into a bit of a challenge. I've added tooltip pop-up boxes to each of the nearly 3200 shapes that contains the county name, as well as information pertinent to that county when the user hovers over it with the mouse. These ToolTips update each time the user selects a new date range.

ISSUE: I've been updating the ToolTips with the code below, but is S-L-O-W (42 seconds). In stark contrast, the re-coloration of the shapes is done in ~1 second, because an ShapeRange array is built assigning the counties into one of 10 bins (colors), and the entire ShapeRange's color is changed in a single statement.

QUESTION: is there any way to assign these Hyperlink Tooltips at the ShapeRange level? Or alternatively, can I make the ToolTip information dynamic so that it doesn't have to be re-assigned at each update?

Any help would be greatly appreciated!

Sub AddToolTips()
Dim oWSF As Object
Dim oMapSheet As Worksheet
Dim rCountyNames As Range
Dim rShapeNames As Range
Dim rCurrentShape As Range
Dim rDataValue As Range
Dim sMetricSelected As String
Dim sPopUpMessage As String
Dim lIndex As Long

  On Error GoTo ERRMESSAGE
  Set oWSF = Application.WorksheetFunction
  Set oMapSheet = Sheets("usa map")
  Set rCountyNames = [myCountyNames]
  Set rShapeNames = [myShapeNames]
  Set rDataValue = [myValues]
  sMetricSelected = oWSF.Index([MetricsColumns], [SelectionMetric])

  'Loop through shapenames and set ToolTips
  For Each rCurrentShape In rShapeNames
    'Set the Index number
    lIndex& = (rCurrentShape.Row& - rCountyNames.Row&) + 1
    
    'Build the ToolTip message
    sPopUpMessage = oWSF.Index(rCountyNames, lIndex&) & _
                    Chr(10) & Chr(10) & _
                    sMetricSelected & ": " & _
                    Format(oWSF.Index(rDataValue, lIndex&), "#0.0%")

    'Add the ToolTip info to the Shape
    oMapSheet.Hyperlinks.Add _
      Anchor:=oMapSheet.Shapes(rCurrentShape.Value), _
      Address:="", _
      ScreenTip:=sPopUpMessage
  Next rCurrentShape

  GoTo CLEANUP

ERRMESSAGE:
  If Err.Number <> 0 Then
    MsgBox Prompt:="Error: " & Err.Number & " - " & Err.Description, _
           Buttons:=vbOKOnly + vbExclamation, _
           Title:="Update Error"
    Err.Clear
  End If
  GoTo CLEANUP

CLEANUP:
  Set rDataValue = Nothing
  Set rShapeNames = Nothing
  Set rCountyNames = Nothing
  Set oMapSheet = Nothing
  Set oWSF = Nothing
End Sub

PS: The code above loops through a shape name index, however I've also tried by looping through the Shapes in the Sheet's ShapeRange, and the execution time is roughly the same.

(Based on the work done by Clearly and Simply (which in turn got their codebase from the great Tushar Mehta))