Code to Insert Value as Comment and Change Color

M

mcgrupp

Board Regular
Joined
Jan 15, 2015
Messages
66
I am looking to automatically update comments on cells in one sheet and fill them with a specific color based on the values of another sheet.
The range is columns 1 through 140 and rows 2 through the last row.
If cell A2 on Sheet 2 changes, then cell A2 on Sheet 1 should have a comment created that has the value reflected in sheet 2 cell A2. This relationship extends to all cells in the range.

I started to tinker and this code will work for the single cell reference but needs to be altered to the range and does not work unless the changes are done manually on Sheet2. That's an issue because Sheet2 has formulas.

As an example, Sheet1 cell A2's is referenced in a formula in Sheet2 cells FA2 and FG2. Sheet2 cellA2 references those two cells. So if a change is made to Sheet 1 cell A2, it can indirectly trigger a value to populate in Sheet2 A2, which should be the comment displayed in Sheet1 A2. I tried to alter the code to delete the comment in the cell if Sheet 2 cell A2 formula result is null, but had issues. When I did some research on how to get around manual inputted changes being the sole driver of the comment additions, I came upon this thread:

excel - VBA code doesn't run when cell is changed by a formula - Stack Overflow

but I am not sure how to alter it to my needs. As for the color fill, I'd use conditional formatting, but there will be other users that won't use paste values at times. Ideally, if Sheet 2 cell A2 formula results have "missing" as part of the text string, then cell.Interior.ColorIndex = 4, if they have "invalid", then cell.Interior.ColorIndex = 3, and if they have "delete", then cell.Interior.ColorIndex = 26. Any help or a point in the right direction would be much appreciated.

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim sResult As String

    If Union(Target, Worksheets("Sheet2").Range("A2")).Address = Target.Address Then
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        sResult = Target.Value
        Target.ClearContents

        With Worksheets("Sheet1").Range("A2")
            .ClearComments
            .AddComment
            .Comment.Text Text:=sResult
        End With
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub
 

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.
Sort by date Sort by votes
One way to do this would be:

  • Use a change event to determine what cell to analyze.
  • Trace direct and indirect dependents and precedents for this cell.
  • Update comments for all addresses found on previous step.
  • I will be back later with an example code.
 
Upvote 0
Thank for responding. I was searching around different sites and tried this code just to see if this could be expanded to all columns needed but I am not getting anywhere:

Code: 
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If Target.Column = 1 Then
        ThisRow = Target.Row
        If Not IsNull(Target.Value) Then
            With Sheets("Sheet1").Range("A" & ThisRow)
            .ClearComments
            .AddComment
            .Comment.Text Text:=Target.Value
        End With
        End If
    End If
End Sub
 
Upvote 0
The relevant features of this example are:

- Monitors changes on a specific range of a sheet named Main.
- Builds a collection of unique addresses, which are dependent on the changed cell.
- Updates comments and cell formatting, if a dependent cell is not located on the main sheet.
- Dependencies outside Main are found using the navigate arrow method.

Code: 
' sheet "Main"
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("d90:e100")) Is Nothing Then UpdateComments Target
End Sub

Code: 
' regular module
Dim coll As New Collection


Sub UpdateComments(ad As Range)
Dim a, i%, r As Range, cell As Range, v
a = oneCellsDep(ad)
On Error Resume Next
For i = 1 To coll.count
    Set r = Range(coll(i)).Dependents   ' direct and indirect
    If Not r Is Nothing Then
        For Each cell In r              ' add to collection
            coll.Add cell.Parent.Name & "!" & cell.Address, CStr(cell.Parent.Name & "!" & cell.Address)
        Next
    End If
Next
On Error GoTo 0
For i = 1 To coll.count
    v = Split(coll(i), "!")
    If v(0) <> "Main" Then
        With Sheets("Main").Range(v(1))
            .ClearComments
            .AddComment
            .Comment.Text Text:=CStr(Sheets(v(0)).Range(v(1)).Value)
            If InStr(Sheets(v(0)).Range(v(1)), "missing") Then Sheets("Main").Range(v(1)).Interior.ColorIndex = 4
            If InStr(Sheets(v(0)).Range(v(1)), "invalid") Then Sheets("Main").Range(v(1)).Interior.ColorIndex = 3
            If InStr(Sheets(v(0)).Range(v(1)), "delete") Then Sheets("Main").Range(v(1)).Interior.ColorIndex = 26
        End With
    End If
Next
Set coll = Nothing
End Sub


Function oneCellsDep(ByVal rng2) As Boolean
'initial code credited to Bill Manville, brettdj and mikerickson
Dim strAddress$, rngReturn As Range, i%, lPreCount&, bFndTarget As Boolean
Set rngReturn = Selection   ' point to return to
strAddress = rng2.Parent.Name & "!" & rng2.Address
With rng2
    .ShowDependents
    .NavigateArrow 0, 1
    On Error Resume Next
    coll.Add ActiveCell.Parent.Name & "!" & ActiveCell.Address, _
    CStr(ActiveCell.Parent.Name & "!" & ActiveCell.Address)
    On Error GoTo 0
    Do Until ActiveCell.Parent.Name & "!" & ActiveCell.Address = strAddress
        lPreCount = lPreCount + 1
        .NavigateArrow 0, lPreCount
        On Error Resume Next
        coll.Add ActiveCell.Parent.Name & "!" & ActiveCell.Address, _
        CStr(ActiveCell.Parent.Name & "!" & ActiveCell.Address)
        If ActiveCell.Parent.Name = "Main" Then
            oneCellsDep = True
        Else
          bFndTarget = oneCellsDep(ActiveCell)
       End If
        .NavigateArrow 0, lPreCount + 1
        coll.Add ActiveCell.Parent.Name & "!" & ActiveCell.Address, _
        CStr(ActiveCell.Parent.Name & "!" & ActiveCell.Address)
        On Error GoTo 0
    Loop
    ActiveCell.ShowDependents Remove:=True
End With
oneCellsDep = True
With rngReturn      'Return selection to where it was
    .Parent.Activate
    .Select
End With
LeaveMe:
End Function
 
Last edited:
Upvote 0
Thank you for posting this. A few questions.

When I attempted to paste into the Main spreadsheet or use autofill, I got a Run Time Error 1004 : NavigateArrow method of Range class failed error message.
The error is pointing to:
Code: 
 .NavigateArrow 0, lPreCount

When the cells on the main sheet are altered, causing their counterpart on Sheet 2 to return a formula result of null, the comment updates and has no text, but the ideal would be for the comment to be deleted. The color formatting would be removed as well. You wouldn't know if there was an issue unless you actually checked the comment to see if it was blank otherwise.

Once again, thank you for your assistance.
 
Upvote 0
The previous code does not account for the fact that one navigation arrow may have several associated links.
I will rewrite it.
 
Upvote 0
  • I am sure I posted this yesterday, but it disappeared…
  • This new version should find all dependencies of the changed cell, workbook wise.
  • It checks whether the cell contains an error or not
  • Color formatting is applied on the main sheet.


Code: 
Dim coll As New Collection
Sub AllDeps(dc As Range)
Dim i%, j%, cell As Range, s$, v, r As Range, mb As Range
On Error Resume Next
dc.ShowDependents
Set cell = dc
For i = 1 To 5                          ' up to 5 arrows
    For j = 1 To 3                      ' up to 3 links
        Application.Goto cell
        ActiveCell.NavigateArrow 0, i, j
        s = Selection.Parent.Name & "!" & Selection.Address
        coll.Add s, CStr(s)
    Next
Next
For i = 1 To coll.Count
    v = Split(coll(i), "!")
    Set r = Sheets(v(0)).Range(v(1)).Dependents
    For Each mb In r
        s = mb.Parent.Name & "!" & mb.Address
        coll.Add s, CStr(s)
    Next
Next
End Sub

Sub UpdateComments(ad As Range)
Dim a, i%, r As Range, cell As Range, v, m As Worksheet
AllDeps ad
Set m = Sheets("Main")
On Error GoTo 0
For i = 1 To coll.Count
    v = Split(coll(i), "!")
    If v(0) <> "Main" Then
        With m.Range(v(1))
            .ClearComments
            .AddComment
            .Comment.Text Text:=CStr(Sheets(v(0)).Range(v(1)).Value)
        End With
        Select Case WorksheetFunction.IsError(Sheets(v(0)).Range(v(1)).Value)
                Case True
                    m.Range(v(1)).ClearComments
                    m.Range(v(1)).Interior.ColorIndex = xlColorIndexNone
                Case False
                    If InStr(Sheets(v(0)).Range(v(1)), "missing") Then m.Range(v(1)).Interior.ColorIndex = 4
                    If InStr(Sheets(v(0)).Range(v(1)), "invalid") Then m.Range(v(1)).Interior.ColorIndex = 3
                    If InStr(Sheets(v(0)).Range(v(1)), "delete") Then m.Range(v(1)).Interior.ColorIndex = 26
        End Select
    End If
Next
Set coll = Nothing
End Sub
 
Upvote 0
Thanks for replying. I actually didn't get notified when you posted. Unfortunately there is no change. Autofill, dragging, pasting, and deleting the same error. I was able to get it so the comment deletes once an acceptable value is entered, but I can't clear out the fill color on the cell. I posted your code with my modifications including the nonworking portion of the code that attempts to clear the color out. Thank you again for your help.

Code: 
' regular module
Dim coll As New Collection


Sub UpdateComments(ad As Range)
Dim a, i%, r As Range, cell As Range, v
a = oneCellsDep(ad)
On Error Resume Next
For i = 1 To coll.Count
    Set r = Range(coll(i)).Dependents   ' direct and indirect
    If Not r Is Nothing Then
        For Each cell In r              ' add to collection
            coll.Add cell.Parent.Name & "!" & cell.Address, CStr(cell.Parent.Name & "!" & cell.Address)
        Next
    End If
Next
On Error GoTo 0
For i = 1 To coll.Count
    v = Split(coll(i), "!")
    If v(0) <> "Main" Then
        With Sheets("Main").Range(v(1))
            .ClearComments
            .AddComment
            .Comment.Text Text:=CStr(Sheets(v(0)).Range(v(1)).Value)
            If InStr(Sheets(v(0)).Range(v(1)), "missing") Then Sheets("Main").Range(v(1)).Interior.ColorIndex = 4
            If InStr(Sheets(v(0)).Range(v(1)), "invalid") Then Sheets("Main").Range(v(1)).Interior.ColorIndex = 3
            If InStr(Sheets(v(0)).Range(v(1)), "delete") Then Sheets("Main").Range(v(1)).Interior.ColorIndex = 26
        End With
    End If
Next
Set coll = Nothing
    Dim Ws      As Worksheet
    Dim Cmt     As Comment
    Dim Txt     As String
    Dim Cnt     As Long
    
    Cnt = 0
    For Each Ws In ActiveWorkbook.Worksheets
        For Each Cmt In Ws.Comments
            Txt = Cmt.Text
            If Len(Trim(Txt)) = 0 Then
                Cnt = Cnt + 1
                Cmt.Delete


            End If
        Next Cmt
    Next Ws
    
For i = 1 To coll.Count
    v = Split(coll(i), "!")
    If v(0) <> "Main" Then
        With Sheets("Main").Range(v(1))
        If Sheets("Main").Range(v(1)).Comment Is Nothing Then
        Sheets("Main").Range(v(1)).Interior.ColorIndex = -4142
        End If
        End With
        End If
        Next
 Set coll = Nothing
        
End Sub
 
Upvote 0
Worf said:
  • I am sure I posted this yesterday, but it disappeared…
  • This new version should find all dependencies of the changed cell, workbook wise.
  • It checks whether the cell contains an error or not
  • Color formatting is applied on the main sheet.


Code: 
Dim coll As New Collection
Sub AllDeps(dc As Range)
Dim i%, j%, cell As Range, s$, v, r As Range, mb As Range
On Error Resume Next
dc.ShowDependents
Set cell = dc
For i = 1 To 5                          ' up to 5 arrows
    For j = 1 To 3                      ' up to 3 links
        Application.Goto cell
        ActiveCell.NavigateArrow 0, i, j
        s = Selection.Parent.Name & "!" & Selection.Address
        coll.Add s, CStr(s)
    Next
Next
For i = 1 To coll.Count
    v = Split(coll(i), "!")
    Set r = Sheets(v(0)).Range(v(1)).Dependents
    For Each mb In r
        s = mb.Parent.Name & "!" & mb.Address
        coll.Add s, CStr(s)
    Next
Next
End Sub

Sub UpdateComments(ad As Range)
Dim a, i%, r As Range, cell As Range, v, m As Worksheet
AllDeps ad
Set m = Sheets("Main")
On Error GoTo 0
For i = 1 To coll.Count
    v = Split(coll(i), "!")
    If v(0) <> "Main" Then
        With m.Range(v(1))
            .ClearComments
            .AddComment
            .Comment.Text Text:=CStr(Sheets(v(0)).Range(v(1)).Value)
        End With
        Select Case WorksheetFunction.IsError(Sheets(v(0)).Range(v(1)).Value)
                Case True
                    m.Range(v(1)).ClearComments
                    m.Range(v(1)).Interior.ColorIndex = xlColorIndexNone
                Case False
                    If InStr(Sheets(v(0)).Range(v(1)), "missing") Then m.Range(v(1)).Interior.ColorIndex = 4
                    If InStr(Sheets(v(0)).Range(v(1)), "invalid") Then m.Range(v(1)).Interior.ColorIndex = 3
                    If InStr(Sheets(v(0)).Range(v(1)), "delete") Then m.Range(v(1)).Interior.ColorIndex = 26
        End Select
    End If
Next
Set coll = Nothing
End Sub
Click to expand...



Hi, I modified the code again and was able to get the fill color out once the cell has been updated and delete,missing, or invalid are no longer displayed. I was fishing around for more info on that error but I couldn't find much of anything. If you're able to take a look at it and let me know why pasting/autofilling/clearing contents can cause this error, it would be much appreciated.

Code: 
' regular module
Dim coll As New Collection


Sub UpdateComments(ad As Range)
Application.ScreenUpdating = False
Dim a, i%, r As Range, cell As Range, v
a = oneCellsDep(ad)
On Error Resume Next
For i = 1 To coll.Count
    Set r = Range(coll(i)).Dependents   ' direct and indirect
    If Not r Is Nothing Then
        For Each cell In r              ' add to collection
            coll.Add cell.Parent.Name & "!" & cell.Address, CStr(cell.Parent.Name & "!" & cell.Address)
        Next
    End If
Next
On Error GoTo 0
For i = 1 To coll.Count
    v = Split(coll(i), "!")
    If v(0) <> "Main" Then
        With Sheets("Main").Range(v(1))
            .ClearComments
            .AddComment
            .Comment.Text Text:=CStr(Sheets(v(0)).Range(v(1)).Value)
            If InStr(Sheets(v(0)).Range(v(1)), "missing") Then Sheets("Main").Range(v(1)).Interior.ColorIndex = 4
            If InStr(Sheets(v(0)).Range(v(1)), "invalid") Then Sheets("Main").Range(v(1)).Interior.ColorIndex = 3
            If InStr(Sheets(v(0)).Range(v(1)), "delete") Then Sheets("Main").Range(v(1)).Interior.ColorIndex = 26
            If (InStr(Sheets(v(0)).Range(v(1)), "delete") = 0) And (InStr(Sheets(v(0)).Range(v(1)), "invalid") = 0) And (InStr(Sheets(v(0)).Range(v(1)), "missing") = 0) Then Sheets("Main").Range(v(1)).Interior.ColorIndex = -4142
        End With
    End If
Next
Set coll = Nothing
    Dim Ws      As Worksheet
    Dim Cmt     As Comment
    Dim Txt     As String
    Dim Cnt     As Long
    
    Cnt = 0
    For Each Ws In ActiveWorkbook.Worksheets
        For Each Cmt In Ws.Comments
            Txt = Cmt.Text
            If Len(Trim(Txt)) = 0 Then
                Cnt = Cnt + 1
                Cmt.Delete


            End If
        Next Cmt
    Next Ws
    

        
End Sub


Function oneCellsDep(ByVal rng2) As Boolean
'initial code credited to Bill Manville, brettdj and mikerickson
Application.ScreenUpdating = False
Dim strAddress$, rngReturn As Range, i%, lPreCount&, bFndTarget As Boolean
Set rngReturn = Selection   ' point to return to
strAddress = rng2.Parent.Name & "!" & rng2.Address
With rng2
    .ShowDependents
    .NavigateArrow 0, 1
    On Error Resume Next
    coll.Add ActiveCell.Parent.Name & "!" & ActiveCell.Address, _
    CStr(ActiveCell.Parent.Name & "!" & ActiveCell.Address)
    On Error GoTo 0
    Do Until ActiveCell.Parent.Name & "!" & ActiveCell.Address = strAddress
        lPreCount = lPreCount + 1
        .NavigateArrow 0, lPreCount
        
        On Error Resume Next
        coll.Add ActiveCell.Parent.Name & "!" & ActiveCell.Address, _
        CStr(ActiveCell.Parent.Name & "!" & ActiveCell.Address)
        If ActiveCell.Parent.Name = "Main" Then
            oneCellsDep = True
        Else
          bFndTarget = oneCellsDep(ActiveCell)
       End If
        .NavigateArrow 0, lPreCount + 1
        coll.Add ActiveCell.Parent.Name & "!" & ActiveCell.Address, _
        CStr(ActiveCell.Parent.Name & "!" & ActiveCell.Address)
        On Error GoTo 0
    Loop
    ActiveCell.ShowDependents Remove:=True
End With
oneCellsDep = True
With rngReturn      'Return selection to where it was
    .Parent.Activate
    .Select
End With
LeaveMe:
End Function
 
Upvote 0
Ok, I took your modified code again and added back in the changes I made in terms of clearing fill color and deleting comments as needed. The NavigateArrow errrors are gone when pasting and dragging, but the functionality still isn't there since pasting values into one column isn't triggering the other columns with dependencies to the pasted in column to have comments inserted and highlight. Hand keying info, everything still works fine with the exception that when you change a cell and hit enter, it will not go to the next cell, it will navigate back to cell you changed.

Code: 
Dim coll As New Collection
Sub AllDeps(dc As Range)
Application.ScreenUpdating = False
Dim i%, j%, cell As Range, s$, v, r As Range, mb As Range
On Error Resume Next
dc.ShowDependents
Set cell = dc
For i = 1 To 5                          ' up to 5 arrows
    For j = 1 To 3                      ' up to 3 links
        Application.Goto cell
        ActiveCell.NavigateArrow 0, i, j
        s = Selection.Parent.Name & "!" & Selection.Address
        coll.Add s, CStr(s)
    Next
Next
For i = 1 To coll.Count
    v = Split(coll(i), "!")
    Set r = Sheets(v(0)).Range(v(1)).Dependents
    For Each mb In r
        s = mb.Parent.Name & "!" & mb.Address
        coll.Add s, CStr(s)
    Next
Next
End Sub

Sub UpdateComments(ad As Range)
Application.ScreenUpdating = False
Dim a, i%, r As Range, cell As Range, v, m As Worksheet
AllDeps ad
Set m = Sheets("Main")
On Error GoTo 0
For i = 1 To coll.Count
    v = Split(coll(i), "!")
    If v(0) <> "Main" Then
        With m.Range(v(1))
            .ClearComments
            .AddComment
            .Comment.Text Text:=CStr(Sheets(v(0)).Range(v(1)).Value)
        End With
        Select Case WorksheetFunction.IsError(Sheets(v(0)).Range(v(1)).Value)
                Case True
                    m.Range(v(1)).ClearComments
                    m.Range(v(1)).Interior.ColorIndex = xlColorIndexNone
                Case False
                    If InStr(Sheets(v(0)).Range(v(1)), "missing") Then m.Range(v(1)).Interior.ColorIndex = 4
                    If InStr(Sheets(v(0)).Range(v(1)), "invalid") Then m.Range(v(1)).Interior.ColorIndex = 3
                    If InStr(Sheets(v(0)).Range(v(1)), "delete") Then m.Range(v(1)).Interior.ColorIndex = 26
                    If (InStr(Sheets(v(0)).Range(v(1)), "delete") = 0) And (InStr(Sheets(v(0)).Range(v(1)), "invalid") = 0) And (InStr(Sheets(v(0)).Range(v(1)), "missing") = 0) Then Sheets("Main").Range(v(1)).Interior.ColorIndex = -4142
        End Select
    End If
Next
Set coll = Nothing
Dim Ws      As Worksheet
    Dim Cmt     As Comment
    Dim Txt     As String
    Dim Cnt     As Long
    
    Cnt = 0
    For Each Ws In ActiveWorkbook.Worksheets
        For Each Cmt In Ws.Comments
            Txt = Cmt.Text
            If Len(Trim(Txt)) = 0 Then
                Cnt = Cnt + 1
                Cmt.Delete


            End If
        Next Cmt
    Next Ws
    ActiveSheet.ClearArrows
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Solved
Subroutine to Add Cell Comments Not Updating the Contents Correctly
Replies
7
Views
307
CephasOz
CephasOz
A
  • Solved
VBA Code to Add a Comment to a Cell based on that Cells Content
2
Replies
11
Views
130
albert_de
A
B
  • Solved
Another VBA question to hide/unhide rows based on cell value in another sheet
2
Replies
12
Views
388
kevin9999
K
J
  • Solved
VBA to compare rows in two different sheets, if match highlight cell
2
Replies
10
Views
580
kevin9999
K
KlausW
  • Solved
Change destination between 2 sheets
Replies
2
Views
131
KlausW
KlausW

Forum statistics

Threads
1,214,641
Messages
6,120,685
Members
448,977
Latest member
dbonilla0331

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top