Unique 'TextTips' Based on Hovered Over Cell Values (Hyperlinked)

With reference to this post ... https://www.excelforum.com/excel-pro...heet-cell.html, I am struggling to figure out a VBA solution to one of the components of my original post there. The solution provided fundamentally works (thank you Kokosek and Lewis), but I have not been able to figure out yet how to display the unique 'texttip' for the row that the user is hovering over. The code, as it is now, displays the same 'texttip' for each cell in that particular range (all the + in column I display "Heavy", ~ in column J display "Moderate" and "Light for column J's - ). I need to enhance those messages based on the row as: (apologize for being unable to display tabular, there are three columns of data illustrated here)

Sym Row Message
+ 13 > 10 cm
+ 14 > 10 cm
+ 15 > 10 cm
+ 16 > 5 mm
+ 17 >5 mm
+ 18 >5 mm
+ 19 > 45 kph

~ 13 5-10 cm
~ 14 5-10 cm
~ 15 5-10 cm
~ 16 1-5 mm
~ 17 1-5 mm
~ 18 1-5 mm
~ 19 20-45 kph

- 13 <5 cm
- 14 <5 cm
- 15 <5 cm
- 16 <1 mm
- 17 <1 mm
- 18 <1 mm
- 19 <20 kph

Would anyone like to assist me in how to best approach this ... to display the appropriate 'texttip' based on which cell within the range the pointer is positioned? I suspect it might involve this portion of code, but I am unsure how to get the value for "srow" identified in my commented out lines of code. Perhaps it can't be done?

Function GetScreenTipTextValue(v As Variant) As String
  'This returns 'Screen Tip Text' Values for certain inputs
  
  Dim sScreenTipText As String
  
  Select Case v
  Stop
    Case "+"
      sScreenTipText = "Plus"
      'if srow =>13 and row <= 16 then sScreenTipText = ">10 cm"
      'if srow =>17 and row <= 18 then sScreenTipText = ">5 mm"
      'if srow = 19 then sScreenTipText = ">45 kph"
    Case "~"
      sScreenTipText = "Moderate"
      'if srow =>13 and row <= 16 then sScreenTipText = "5-10 cm"
      'if srow =>17 and row <= 18 then sScreenTipText = "1-5 mm"
      'if srow = 19 then sScreenTipText = "20-45 kph"
    Case "-"
      sScreenTipText = "Minus"
     'if srow =>13 and row <= 16 then sScreenTipText = "<5 cm"
      'if srow =>17 and row <= 18 then sScreenTipText = "<1 mm"
      'if srow = 19 then sScreenTipText = "<20 kph"
  End Select
  
  'Set the return value
  GetScreenTipTextValue = sScreenTipText

End Function

Hi,

Try the attached copy of your modified file. The '-' sign column worked intermittently for me, so I changed it to 'x' and it worked every time for me. You may want to try to change it back to '-' sign, and see how it works for you.

In the future, please upload your sample file to the thread - you will get better and quicker responses, as responders want to do as little work as possible testing and looking for files.

Changed code follows:

Function GetScreenTipTextValue(v As Variant, iRow As Long) As String
  'This returns 'Screen Tip Text' Values for certain inputs
  Dim sScreenTipText As String
  
 xSelect xCase v
    
    xCase "+"

      xSelect xCase iRow
        xCase 13 To 15
          sScreenTipText = ">10 cm"
        xCase 16, 17, 18
          sScreenTipText = ">5 mm"
        xCase 19
          sScreenTipText = ">45 kph"
      End xSelect
      
    xCase "~"
    
      xSelect xCase iRow
        xCase 13 To 15
          sScreenTipText = "5-10 cm"
        xCase 16, 17, 18
          sScreenTipText = ">1-5 mm"
        xCase 19
          sScreenTipText = "20-45 kph"
      End xSelect
      
    'NOTE: Had intermittent results with '-', replaced with 'x' and seemed to work all the time
    xCase "x"
    
      xSelect xCase iRow
        xCase 13 To 15
          sScreenTipText = "<5 cm"
        xCase 16, 17, 18
          sScreenTipText = "<1 mm"
        xCase 19
          sScreenTipText = "<20 kph"
      End xSelect
      
  End xSelect  'Set the return value
  GetScreenTipTextValue = sScreenTipText

End Function



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 iRow 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
  'Get the Row Number
  vValue = r.Value
  iRow = r.Row
  
  ''''''''''''''''''''''''''''''''''''''''''''''''''''
  ''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Get the the 'Screen Tip Text' Value
  ''''''''''''''''''''''''''''''''''''''''''''''''''''
  ''''''''''''''''''''''''''''''''''''''''''''''''''''
  sScreenTipText = GetScreenTipTextValue(vValue, iRow)
  
  '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
  
  End If
 
End Sub

NOTE: Had to replace 'Case' with 'xCase' and 'Select' with 'xSelect' to get past Excelforum firewall

Lewis

Hi Lewis! Thank you so much. I was on the right track with my own guessing, but you cleaned things up for me. Working well!

I was happy to help. Your commented out lines in the code made things easy.