Excel Note VBA

[jhedges]

Team,

I have the following code in place to allow our team members to double click in a cell, get a msgbox for them to type into, which adds a note into the cell (red triangle top right corner). This all works fine...Except - If the person hits cancel in the msgbox it actually deletes the actual text in the Excel cell that they double clicked into. I have tried to comment out the last line of code 'Cancel = True, I have tried Cancel = False as well as Cancel = True none of which works to stop the text from being deleted out of the cell. Does anyone have some advice/recommendations to solve this issue?

'Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
    On Error Resume Next
    Dim cmtText As String
    Dim staffText As String
    Dim goalText As String
    Dim Pos As Long
    Dim i As Integer
    Dim text As String
    Dim lArea As Long
    Dim TotalCommentLength As String
    Dim cmtTextLength As Long
    Dim NameLength As Long
    Dim GoalLength As Long
    Dim StaffLength As Long
    Dim StartPos As Long
    
    cmtText = InputBox("Please Enter 90 Day Action Plan(s):", "Action the Day")
    staffText = ActiveCell.Offset(0, -3).Value
    'goalText = ActiveCell.Offset(0, 0).Value
    If cmtText = "" Then Exit Sub
    NameLength = Len(Application.UserName)
    GoalLength = Len(goalText)
    StaffLength = Len(staffText)
    'include line feed at end of text to prevent format bleeding
    cmtText = Format(Now, "mm/dd/yy hh:mm:ss ampm") & "-" & Application.UserName & "-" & staffText & " " & goalText & " " & vbCrLf & "STAFF 90day Plan:" & " " & cmtText & Chr(10)
    cmtTextLength = Len(cmtText)
    If Target.Comment Is Nothing Then
        Target.AddComment text:=cmtText
    Else
        Target.NoteText Chr(10) & cmtText, 99999
    End If
    'Auto size the comment area
    With Target.Comment.Shape
        .TextFrame.AutoSize = True
        If .Width > 350 Then
            lArea = .Width * .Height
            .TextFrame.AutoSize = False
            .Width = 350
            ' An adjustment factor of 0.8 seems to work ok.
            .Height = (lArea / 350) * 0.9
        End If
    End With
    'color the date and name text
    
    TotalCommentLength = Len(Target.Comment.text)
    StartPos = TotalCommentLength - cmtTextLength + 1
    Target.Comment.Shape.TextFrame.Characters(StartPos, 20).Font.ColorIndex = 10
    Target.Comment.Shape.TextFrame.Characters(StartPos + 21, NameLength).Font.ColorIndex = 3
    Target.Comment.Shape.TextFrame.Characters(StartPos + 21 + StaffLength + 1 + NameLength + 1).Font.ColorIndex = 46
    Target.Comment.Shape.TextFrame.Characters(StartPos + 21 + StaffLength + 1 + NameLength + 1, GoalLength + 1).Font.ColorIndex = 32
    Target.Comment.Shape.TextFrame.Characters(StartPos + 21 + StaffLength + 1 + NameLength + 1 + GoalLength + 1, cmtTextLength + 1).Font.ColorIndex = 46

    'Cancel = True    'Remove this if you want to enter text in the cell after you add the comment
    
End Sub

 

[Fluff]

How about

    If cmtText = "" Then
      Cancel = True
      Exit Sub
    End If

 

[jhedges]

If cmtText = "" Then Cancel = True Exit Sub End If

Thanks! This worked perfectly.

 

[Fluff]

You're welcome & thanks for the feedback