Create a cell comment from a vlookup or xlookup

[Gem866]

I am using Excel on a Mac and I can insert VBA code through the developer tab.

The purpose of this spreadsheet is to have a visual of sites allocated & available on a campground and will be used for an annual camping event for our organisation.

I have two sheets in my workbook (See attached images being screen shots of the worksheets)
Sheet1 has data in two columns. Column A is 'Site Number' Column B is 'Camper Name'
Sheet 2 has a site map layout so for example Row 4 shows sites 1 to 13 with 1 site allocated per column eg A4 = 1. (site 1), M4=13 (Site 13)

I currently have conditional formatting on Sheet 2 on the site numbers which does a lookup and if there is a name beside the site number from sheet 1 it will colour the cell red (meaning not available) but if the camper name from sheet 1 is blank it colours the cell green (meaning available). The conditional formatting is all good and working well. I created the conditional formatting using an xlookup function.

What I want to be able to do now is for a comment to be automatically added to the corresponding site number cell on sheet 2. That comment data comes from a lookup from sheet 1. The comment is to be the camper name, which is column B sheet 1. Of course if that camper name on Sheet 1 changes or is deleted the comment will need to update or be deleted accordingly.

Example, if on sheet 1, site 10 has the camper name 'John' then I want a comment added to site 10 on sheet 2. When I select site 10 in sheet 2 I want a comment box to pop up that says John. If there is no camper associated with site 10 I dont want the comment box created.

It should be noted that this is just a sample set of data it could well be that we are dealing with 500 sites or more all up, meaning on sheet 1 columns A & B could run down to row 500 or more.

Can this be done via VBA ?

Look forward to any help you can provide.

With thanks

 

[kevin9999]

a comment to be automatically added

Will require a Worksheet Change event triggered code. The following should do what you want, but please note the ranges for sheet 2 will have to be adjusted according to your "500" sites. Please try on a copy of your workbook. Right click the sheet tab for sheet 1, select View Code, and puth the code in the empty window that appears on the right of the screen.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge = 1 And Not _
    Intersect(Range("B6:B" & Cells(Rows.Count, "A").End(xlUp).Row), Target) Is Nothing Then
        On Error GoTo Escape
        Application.EnableEvents = False
        Dim n As String, s As String, SiteNum As Range, com As Comment
        n = Target.Value
        s = Target.Offset(, -1).Value
        Set SiteNum = Worksheets("Sheet2").Range("A4:M6").Find(s)
        
        With SiteNum
            .ClearComments
            If n <> "" Then .AddComment (n)
        End With
        
    End If
Continue:
    Application.EnableEvents = True
    Exit Sub
Escape:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Continue
End Sub

 

[Gem866]

Will require a Worksheet Change event triggered code. The following should do what you want, but please note the ranges for sheet 2 will have to be adjusted according to your "500" sites. Please try on a copy of your workbook. Right click the sheet tab for sheet 1, select View Code, and puth the code in the empty window that appears on the right of the screen.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge = 1 And Not _
    Intersect(Range("B6:B" & Cells(Rows.Count, "A").End(xlUp).Row), Target) Is Nothing Then
        On Error GoTo Escape
        Application.EnableEvents = False
        Dim n As String, s As String, SiteNum As Range, com As Comment
        n = Target.Value
        s = Target.Offset(, -1).Value
        Set SiteNum = Worksheets("Sheet2").Range("A4:M6").Find(s)
       
        With SiteNum
            .ClearComments
            If n <> "" Then .AddComment (n)
        End With
       
    End If
Continue:
    Application.EnableEvents = True
    Exit Sub
Escape:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Continue
End Sub

Thank you that has worked perfectly. I acknowledge the change that will need to be made to the range for sheet 2 when more sites are added.

 

[kevin9999]

Thank you that has worked perfectly. I acknowledge the change that will need to be made to the range for sheet 2 when more sites are added.

Happy to help, and thanks for the feedback