Add cell value to cell comments

[jhedges]

I have the following code I adapted from the internet (not sure where I got this...). When you double-click into a cell it essentially opens a msgbox and then allows you to enter a comment into a cell. With the date and logged in user I would like the activecell.value in the same row 3 columns over (to the left) to be displayed along with the comment. I have tried the following code in red so far; however, it is not displaying the cell value. Can anyone help me out?

'Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
    On Error Resume Next
    Dim cmtText As String
    [COLOR=#ff0000]Dim cellText As String[/COLOR]
    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 StartPos As Long
    Dim ThePW As String
    ThePW = InputBox("A password is required to run this procedure." & vbCrLf & "please enter the password:", "Password")
    If ThePW <> "xxxxxxx" Then Exit Sub
    cmtText = InputBox("Please enter Goals(s):", "Goal Text")
   [COLOR=#ff0000] cellText = ActiveCell.Offset(0, 3).Value[/COLOR]
    If cmtText = "" Then Exit Sub
    UnProtect
    NameLength = Len(Application.UserName)
    'include line feed at end of text to prevent formatt bleeding
    cmtText = Format(Now, "mm/dd/yy hh:mm:ss ampm") & "-" & Application.UserName & "  " &[COLOR=#ff0000] cellText[/COLOR] & " " & cmtText & Chr(10)
    cmtTextLength = Len(cmtText)
    If Target.Comment Is Nothing Then
        Target.AddComment text:=cmtText
        'Target.Comment.Visible = True
    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.8
        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 = 41
    Target.Comment.Shape.TextFrame.Characters(StartPos + 21, NameLength).Font.ColorIndex = 3
    'some of your code follows
    Dim Col As Integer, Row As Integer
    Row = Target.Row
    Col = Target.Column
    ' 'Call function to format cell
    If Not Target Is Nothing Then
        'FormatCellTemplateSheet Row, Col
    End If
    Cancel = True    'Remove this if you want to enter text in the cell after you add the comment
End Sub

 

[Momentman]

3 columns to the left should be offset(0,-3) and not 3

 

[jhedges]

Momentman - Thanks for your help! It is always the little things holding me back with the code I try...My brain was thinking to the left and my hand was not having it...

I do have one final question. I'm trying to color the cellText value green; however, I'm getting an error message with the code I have so far. Any advice?

    'color the date and name text
    TotalCommentLength = Len(Target.Comment.text)
    StartPos = TotalCommentLength - cmtTextLength + 1
    Target.Comment.Shape.TextFrame.Characters(StartPos, 20).Font.ColorIndex = 41
    Target.Comment.Shape.TextFrame.Characters(StartPos + 21, NameLength).Font.ColorIndex = 3
    Target.Comment.Shape.TextFrame.Characters(StartPos + 22, cellText).Font.ColorIndex = 10

 

[gallen]

As far as I'm aware you can't change the colour of the comment text.

 

[jhedges]

***UPDATE***

Here is the revised code, which is working.

The date and time are in blue
Application.Username in red
staffText & cmtText in black
goalText in purple

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
    Dim ThePW As String
    ThePW = InputBox("A password is required to run this procedure." & vbCrLf & "please enter the password:", "Password")
    If ThePW <> "xxx" Then Exit Sub
    cmtText = InputBox("Please enter Goals(s):", "Goal Text")
    staffText = ActiveCell.Offset(0, -3).Value
    goalText = ActiveCell.Offset(0, 0).Value
    If cmtText = "" Then Exit Sub
    UnProtect
    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 & " " & "STAFF GOAL:" & " " & 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.8
        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 = 41
    Target.Comment.Shape.TextFrame.Characters(StartPos + 21, NameLength).Font.ColorIndex = 3
    Target.Comment.Shape.TextFrame.Characters(StartPos + 21 + StaffLength + 1 + NameLength + 2, GoalLength).Font.ColorIndex = 29
    Cancel = True    'Remove this if you want to enter text in the cell after you add the comment
End Sub

 

[Momentman]

So you are sorted now?

 

[jhedges]

Momentman - Yes and thanks for your help!