I Broke My Code : Create cell "Text tips" using hyperlinks

[Ark68]

I am using this code to create specific "text tips" that display when a user hovers the mouse pointer over a particular cell within the worksheet (ws_gui) range of I13:L19. It worked wonderfully, but then I changed some code and now, periodically (I can't figure out what is causing it to recreate it), I get an "Object required" error with the line highlighted in red. I hope someone can help me identify why I am getting this error, and what I can do to ensure I don't get it moving forward.

Workbook Open Event:

Private Sub Workbook_Open()
    Call part1
    Stop
    Call AddScreenTipTextTosRange
    Initiate1
    Stop
End Sub

part1 module:

Option Explicit

Public Const sRANGE = "I13:L19"
Public mbevents As Boolean
Public ws_gui As Worksheet
Public ws_lists As Worksheet
Public ws_data As Worksheet

Sub part1()

    Set ws_gui = ThisWorkbook.Worksheets(1) 'GUI
    Set ws_lists = ThisWorkbook.Worksheets(2) 'Lists
    Set ws_data = ThisWorkbook.Worksheets(3) 'Data

End Sub

ScreenTipText Module:

Option Explicit

'Public Const sRANGE = "I13:L19"

Function GetScreenTipTextValue(v As Variant, rrow As Long) As String
  'This returns 'Screen Tip Text' Values for certain inputs
  Dim sScreenTipText As String
  Select Case v
  'Stop
    Case "+"
      If rrow >= 13 And rrow <= 15 Then
        sScreenTipText = ">10 cm"
      ElseIf rrow >= 16 And rrow <= 18 Then
        sScreenTipText = ">5 mm"
      Else
        sScreenTipText = ">45 KpH"
      End If
      'sScreenTipText = "Plus"
    Case "~"
      If rrow >= 13 And rrow <= 15 Then
        sScreenTipText = "5-10 cm"
      ElseIf rrow >= 16 And rrow <= 18 Then
        sScreenTipText = "1-5 mm"
      Else
        sScreenTipText = "20-45 KpH"
      End If
      'sScreenTipText = "Moderate"
    Case "-"
      If rrow >= 13 And rrow <= 15 Then
        sScreenTipText = "<5 cm"
      ElseIf rrow >= 16 And rrow <= 18 Then
        sScreenTipText = "<1 mm"
      Else
        sScreenTipText = "<20 KpH"
      End If
      'sScreenTipText = "Minus"
  End Select
  'Set the return value
  GetScreenTipTextValue = sScreenTipText
End Function


Sub AddScreenTipTextTosRange()
  'This adds 'Screen Tip Text' to cells in Column C that contain special values
  'Only Cells that are CONSTANTS are processed
  'Cells that are the result of FORMULAS are left AS IS

  Dim myRange As Range
  Dim r As Range
  Dim rrow As Long
 
  'Remove Hyperlinks from all cells in the range
  'Stop
  Call RemoveAllHyperlinksFromsRange
 
  'Process Errors Here (in this macro)
  On Error Resume Next
 
  'Get the range of cells that are CONSTANTS
  Set myRange = Nothing
  Set myRange = ActiveSheet.Range(sRANGE).SpecialCells(xlCellTypeConstants)
  If Err.Number <> 0 Then
    Err.Clear
    Set myRange = Nothing
  End If
  'Debug.Print myRange.Address
 
  'Resume Normal Excel Error Processing
  On Error GoTo 0
 
  'Create 'Screen Tip Text' for each applicable cell
  If Not myRange Is Nothing Then
    For Each r In myRange
      Debug.Print r.Address, r.Value
      rrow = r.Row
      Call AddScreenTipTextToCell(r)
    Next r
  End If

  'Clear object pointers
  Set myRange = Nothing

End Sub


Sub AddScreenTipTextToCell(r As Range)
  'This adds 'Screen Tip Text' to a cell by creating a dummy hyperlink
  'Nothing is done if the input range is more than one cell
  '
  'The existing 'Screen Tip Text' is DELETED before adding the new 'Screen Tip Text'
  'even if there is NO NEW 'Screen Tip Text'
 
  Dim sScreenTipText As String
  Dim vValue As Variant
  'Stop
  'Font attributes
  Dim sFontName As String
  Dim sFontStyle As String
  Dim xFontSize As Double
  Dim bStrikethrough As Boolean
  Dim bSuperscript As Boolean
  Dim bSubscript As Boolean
  Dim bOutlineFont As Boolean
  Dim bShadow As Boolean
  Dim iUnderline As Long
  Dim iColorIndex As Long
  Dim rrow As Long
 
  'Exit if the input range is more than one cell
  If r.Count > 1 Then
    Exit Sub
  End If
 
  'Get the value in the Cell
  vValue = r.Value
  rrow = r.Row
 
  ''''''''''''''''''''''''''''''''''''''''''''''''''''
  ''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Get the the 'Screen Tip Text' Value
  ''''''''''''''''''''''''''''''''''''''''''''''''''''
  ''''''''''''''''''''''''''''''''''''''''''''''''''''
  sScreenTipText = GetScreenTipTextValue(vValue, rrow)
 
  'Get the values of various Font Attributes of the cell
  'This is needed because adding a Hyperlink changes Font Attributes
  With r.Font
    sFontName = .Name
    sFontStyle = .FontStyle
    xFontSize = .Size
    bStrikethrough = .Strikethrough
    bSuperscript = .Superscript
    bSubscript = .Subscript
    bOutlineFont = .OutlineFont
    bShadow = .Shadow
    iUnderline = .Underline
    iColorIndex = .ColorIndex
  End With
 
  'Remove any Hyperlink from the Cell
  r.Hyperlinks.Delete
 
  'Create the Dummy HyperLink that contains 'Screen Tip Text'
  'only if the 'Screen Tip Text' value is NOT BLANK
  If Len(sScreenTipText) > 0 Then
    ActiveSheet.Hyperlinks.Add _
      Anchor:=r, _
      Address:="", _
      SubAddress:="", _
      ScreenTip:=sScreenTipText
 
    'Set the values of various Font Attributes of the cell to the original values
    With r.Font
      .Name = sFontName
      .FontStyle = sFontStyle
      .Size = xFontSize
      .Strikethrough = bStrikethrough
      .Superscript = bSuperscript
      .Subscript = bSubscript
      .OutlineFont = bOutlineFont
      .Shadow = bShadow
      .Underline = iUnderline
      .ColorIndex = iColorIndex
    End With
 
    With Range(r.Address)
        .HorizontalAlignment = xlCenter
        .Interior.ColorIndex = -4142
        .BorderAround Color:=RGB(20, 130, 171), Weight:=xlThin
    End With
  End If
End Sub


Sub RemoveAllHyperlinksFromsRange()
  'This removes all Hyperlinks from I13:K19

  Dim myRange As Range
 
  'Process Errors Here (in this macro)
  On Error Resume Next
 
  'Get the range of cells that are CONSTANTS
  Set myRange = Nothing
  Set myRange = ActiveSheet.Range(sRANGE).SpecialCells(xlCellTypeConstants)
  Debug.Print Err.Number  'err.number = 1004
  If Err.Number <> 0 Then
    Err.Clear 'err.number = 0
    Debug.Print Err.Number
    Set myRange = Nothing
  End If
  'Debug.Print myRange.Address
 
  'Resume Normal Excel Error Processing
  On Error GoTo 0
 
  'Delete the Hyperlinks
  Call RemoveAllHyperlinksFromRange(myRange)
 
  'Clear object pointer
  Set myRange = Nothing
End Sub


Sub RemoveAllHyperlinksFromRange(myRange As Range)
  'This removes 'Screen Tip Text' for all cells in a range
  '
  'Removing HyperLinks changes Font Attributes of the Cell
  'This will keep FONT attributes the same
  '
  'It is the calling routine's responsibility to make sure the input range is valid
 
  Dim r As Range

  'Font attributes
  Dim sFontName As String
  Dim sFontStyle As String
  Dim xFontSize As Double
  Dim bStrikethrough As Boolean
  Dim bSuperscript As Boolean
  Dim bSubscript As Boolean
  Dim bOutlineFont As Boolean
  Dim bShadow As Boolean
  Dim iUnderline As Long
  Dim iColorIndex As Long
 
  For Each r In myRange
 
    'Only access cells with Hyperlinks
    If r.Hyperlinks.Count > 0 Then
        Debug.Print r.Address
      'Get the values of various Font Attributes of the cell
      'This is needed because adding a Hyperlink changes Font Attributes
      With r.Font
        sFontName = .Name
        sFontStyle = .FontStyle
        xFontSize = .Size
        bStrikethrough = .Strikethrough
        bSuperscript = .Superscript
        bSubscript = .Subscript
        bOutlineFont = .OutlineFont
        bShadow = .Shadow
        iUnderline = .Underline
        iColorIndex = .ColorIndex
      End With
 
      'Remove the Hyperlink from the cell if it exists
      r.Hyperlinks.Delete
     
      'Set the values of various Font Attributes of the cell to the original values
      With r.Font
        .Name = sFontName
        .FontStyle = sFontStyle
        .Size = xFontSize
        .Strikethrough = bStrikethrough
        .Superscript = bSuperscript
        .Subscript = bSubscript
        .OutlineFont = bOutlineFont
        .Shadow = bShadow
        .Underline = iUnderline
        .ColorIndex = iColorIndex
      End With
   
      'test
      With Range(r.Address)
        .HorizontalAlignment = xlCenter
        .Interior.ColorIndex = -4142
        .BorderAround Color:=RGB(20, 130, 171), Weight:=xlThin
      End With
   
    End If

  Next r
End Sub

I hope someone can assist. Any help would be greatly appreciated.

 

[RoryA]

Why would you set myRange to Nothing and then still call RemoveAllHyperlinksFromRange?

 

[Ark68]

No idea. That was how the code was presented to me as (it was code that was provided to me). It worked well until I added the part1 and initiate1 call procedures to the workbook open event. Originally, only the Call AddScreenTipTextTosRange existed in the workbook open code and everything worked. No error. And it doesn't error all the time.

 

[Ark68]

I eliminated my code and replaced it with the code provided and things are working again. Not sure what I broke as all I recall doing was changing the names of the procedures.