Comments based on criteria

desuth

New Member
Joined
Dec 5, 2017
Messages
21
Office Version
  1. 2016
I found this VBA on how to make it where comments are based on certain criteria, but i need it to do just a bit more and i am stumped. What i need it to do is to pick out a cell value for a range in column A and put the comment in the cell of the same row in column G. I need it to do this for 1000 rows.
Below is the code i have found that needs a modification.

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng As Range
    Dim cell As Range
    Dim c As Comment

    On Error GoTo haveError

    'see if any changes are in the monitored range...
    Set rng = Application.Intersect(Target, Me.Range("C2"))

    If Not rng Is Nothing Then
    'Next line prevents code updates from re-triggering this...
    '  (Not really needed if you're only adding comments)
        Application.EnableEvents = False
        For Each cell In rng.Cells
               If cell.Value = "Croatia" Then
                   Set rng = ActiveSheet.Cells(4, 3)
                   If Not (rng.Comment Is Nothing) Then rng.Comment.Delete
                   cell.Offset(2, 0).AddComment "Happy is as happy does"
                   'cell.Offset(0, 2).AddComment "fi"
                   'cell.Offset(0, 3).AddComment "fo"
               End If
              
               If cell.Value = "France" Then
                   Set rng = ActiveSheet.Cells(4, 3)
                   If Not (rng.Comment Is Nothing) Then rng.Comment.Delete
                   cell.Offset(2, 0).AddComment "Maybe yes"
                   'cell.Offset(0, 2).AddComment "fi"
                   'cell.Offset(0, 3).AddComment "fo"
               End If
              
               If cell.Value = "Spain" Then
                   Set rng = ActiveSheet.Cells(4, 3)
                   If Not (rng.Comment Is Nothing) Then rng.Comment.Delete
                   cell.Offset(2, 0).AddComment "Probably no"
                   'cell.Offset(0, 2).AddComment "fi"
                   'cell.Offset(0, 3).AddComment "fo"
               End If
              
                   For Each c In ActiveSheet.Comments
                     c.Visible = False
                   Next
              
            Next
       
        Application.EnableEvents = True
    End If
    Exit Sub

haveError:
    MsgBox Err.Description
    Application.EnableEvents = True

End Sub
 
Last edited:

Some videos you may like

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,129
Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your sheet and click 'View Code'. Paste the macro into the empty code window that opens up. I have used a,b,c and d for the aircraft names (in red) and beside each aircraft name is the comment associated with that aircraft (in blue). You will have to change the array of aircraft names and comments to match your actual names and comments. You will have to include all the aircraft names and associated comments in the array. If in future you add or remove names and comments, the array will have to be manually changed to reflect those changes. Close the code window to return to your sheet. You will be able to add one aircraft name at a time or copy/paste multiple aircraft names in column A. I hope this makes sense.
Rich (BB code):
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim arr As Variant, i As Long, rng As Range
    arr = Array("a", "a is good", "b", "b is bad", "c", "c is fair", "d", "d is OK")
    For Each rng In Target
        For i = LBound(arr) To UBound(arr) Step 2
            If rng = arr(i) Then
                If Not Range("D" & rng.Row).Comment Is Nothing Then Range("D" & rng.Row).Comment.Delete
                Range("D" & rng.Row).AddComment arr(i + 1)
                Exit For
            End If
        Next i
    Next rng
    Application.ScreenUpdating = True
End Sub
 

desuth

New Member
Joined
Dec 5, 2017
Messages
21
Office Version
  1. 2016
Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your sheet and click 'View Code'. Paste the macro into the empty code window that opens up. I have used a,b,c and d for the aircraft names (in red) and beside each aircraft name is the comment associated with that aircraft (in blue). You will have to change the array of aircraft names and comments to match your actual names and comments. You will have to include all the aircraft names and associated comments in the array. If in future you add or remove names and comments, the array will have to be manually changed to reflect those changes. Close the code window to return to your sheet. You will be able to add one aircraft name at a time or copy/paste multiple aircraft names in column A. I hope this makes sense.
Rich (BB code):
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim arr As Variant, i As Long, rng As Range
    arr = Array("a", "a is good", "b", "b is bad", "c", "c is fair", "d", "d is OK")
    For Each rng In Target
        For i = LBound(arr) To UBound(arr) Step 2
            If rng = arr(i) Then
                If Not Range("D" & rng.Row).Comment Is Nothing Then Range("D" & rng.Row).Comment.Delete
                Range("D" & rng.Row).AddComment arr(i + 1)
                Exit For
            End If
        Next i
    Next rng
    Application.ScreenUpdating = True
End Sub
works like a champ thank you!!!!
 

Watch MrExcel Video

Forum statistics

Threads
1,122,832
Messages
5,598,360
Members
414,233
Latest member
WolverineNurse

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
Top