VBA Runtime Error when Selecting Dropdown List

[Tigron]

Hello community,

first of all I'd like to note, that I am a complete noob when it comes to VBA. Unlike other programming languages such as HTML, CSS or even Python, VBA doesn't really "speak with me", which makes finding a solution - or just even playing around with the code - pretty difficult. I feel "a tiny bit" overwhelmed.

I am working on a trading journal in Excel (I trade cryptocurrencies) and found a solution to an issue I had. I wanted to be able to put long notes on my individual trades in a very small cell and, when reviewing my trades in retrospect, be able to "hover over" that cell and have a pop-up appear with the complete text. I found a great solution here: Link

The problem with this solution is that, whenever I select a cell that contains a dropdown list, I get a VBA runtime error. Please view screen shots for the exact message.

The code I am using looks like this:

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    Const SHAPENAME As String = "MessageShape"
    Dim ws As Worksheet
    Dim oshp As Shape
    Dim icount As Integer
    Dim iX As Integer
    Dim iY As Integer
    Dim iHeight As Integer
    Dim iWidth As Integer
    
    Set ws = ActiveSheet
    
    'Only run if one cell is selected
    If Target.Count > 1 Then Exit Sub
    
    'Delete any existing shapes. We run though all shapes backwards
    For icount = ws.Shapes.Count To 1 Step -1
        Set oshp = ws.Shapes(icount)
        If (oshp.Name = SHAPENAME) Then
            oshp.Delete
        End If
    Next icount
    
    'Lets grab the position of the selected cell, we'll use this to place the message box just to the right of it.
    'We add 5 to the position to give it a pleasant offset
    iX = Target.Cells(1, 2).Left + 5
    iY = Target.Top + 5
    iHeight = 200 'Adjust the box height by changing this
    iWidth = 450 'Adjust the box widthby changing this
    
    'Show the message box - Amend this if you want to change the position
    Select Case Target.Column
            Case 21, 32, 37 'Add column numbers here
            Set oshp = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, iX, iY, iWidth, iHeight)
            oshp.TextFrame2.TextRange.Characters.Text = Target.Value
            oshp.Name = SHAPENAME
    End Select

End Sub

Can someone explain what is going wrong here and how to solve this issue. You would make me a immensely happy camper.
One last thing: I would also like to change the background color and the font color of the pop-up, but I have no idea as to where I have to paste the code.

Thanks in advance for any help you can provide!

 

[lrobbo314]

See if changing this line works.

Original

For icount = ws.Shapes.Count To 1 Step -1

New

For icount = ws.Shapes.Count -1 To 1 Step -1

 

[Tigron]

That gets rid of the runtime error. However, the pop-ups will not disappear once I click into a cell that doesn't contain any notes.

 

[lrobbo314]

So, if you don't want the code to fire when you are clicking on a cell that has a drop down, let's say that cell is 'A1', you could write code like below.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Range("A1"), Target) Is Nothing Then
    Const SHAPENAME As String = "MessageShape"
    Dim ws As Worksheet
    Dim oshp As Shape
    Dim icount As Integer
    Dim iX As Integer
    Dim iY As Integer
    Dim iHeight As Integer
    Dim iWidth As Integer

    Set ws = ActiveSheet

    'Only run if one cell is selected
    If Target.Count > 1 Then Exit Sub

    'Delete any existing shapes. We run though all shapes backwards
    For icount = ws.Shapes.Count To 1 Step -1
        Set oshp = ws.Shapes(icount)
        If (oshp.Name = SHAPENAME) Then
            oshp.Delete
        End If
    Next icount

    'Lets grab the position of the selected cell, we'll use this to place the message box just to the right of it.
    'We add 5 to the position to give it a pleasant offset
    iX = Target.Cells(1, 2).Left + 5
    iY = Target.Top + 5
    iHeight = 200 'Adjust the box height by changing this
    iWidth = 450 'Adjust the box widthby changing this

    'Show the message box - Amend this if you want to change the position
    Select Case Target.Column
            Case 21, 32, 37 'Add column numbers here
            Set oshp = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, iX, iY, iWidth, iHeight)
            oshp.TextFrame2.TextRange.Characters.Text = Target.Value
            oshp.Name = SHAPENAME
    End Select
End If
End Sub

 

[Tigron]

Hmm, that doesn't work. Yes, I can click into that specific cell without getting an error message, but once I click into a cell from column 21, 32 or 37 (where my notes are), the error message appears again.

 

[lrobbo314]

After adding data to a test sheet, I think I'm getting what you want now.

Let me know if this works.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Const SHAPENAME As String = "MessageShape"
Dim ws As Worksheet
Dim oshp As Shape
Dim icount As Integer
Dim iX As Integer
Dim iY As Integer
Dim iHeight As Integer
Dim iWidth As Integer

Set ws = ActiveSheet

For icount = ws.Shapes.Count To 1 Step -1
    Set oshp = ws.Shapes(icount)
    If (oshp.Name = SHAPENAME) Then
        oshp.Delete
    End If
Next icount

iX = Target.Cells(1, 2).Left + 5
iY = Target.Top + 5
iHeight = 200
iWidth = 450

If Not IsEmpty(Target.Value) Then
    Select Case Target.Column
            Case 21, 32, 37
            With ws.Shapes.AddTextbox(msoTextOrientationHorizontal, iX, iY, iWidth, iHeight)
                .TextFrame2.TextRange.Characters.Text = Target.Value
                .Name = SHAPENAME
                .BackgroundStyle = msoBackgroundStylePreset10
            End With
    End Select
End If
End Sub

 

[Tigron]

I'm still getting an error message once I click into a dropdown cell. The error stems from this piece of code:

    Set oshp = ws.Shapes(icount)

If you like, I can provide you the Excel file for testing purposes.

By the way: thank you very much for your help! I would be completely lost without it.

 

[lrobbo314]

Maybe that would be best. I can't replicate the error that you are getting. I added dropdowns and regular text and the code seems to be working as expected.

 

[Tigron]

Can you try to contact me via private message? I see an option where I can look at my conversations, but I cannot start a new conversation. I'm guessing because I am new to the forum I can't access this feature...??
I would like to send you the xlsm file via email (or PM, if that is possible).

 

[lrobbo314]

Lol. Guess you're right. Must be because you are a new member. I don't have the option to send you a message either.

You can post the file on dropbox or onedrive or something like that and post the link here.