How to auto add comments based on date on separate sheet

cpereznj · Dec 18th 2018

Hi there, I have a file used to track quantities based on dates. The file has three sheets: "2018", "2019" and "Events". Need the events in the "Events" sheet to auto populate comments in the corresponding "2018" or "2019" sheets based on the dates. For example:

"Events" A3 - Event 1 should be placed in "2018" A3. This is because the date in "2018" B3 matches the date in "Events" B3.
"Events" A4 - Event 2 should be placed in "2018" D3. This is because the date in "2018" E3 matches the date in "Events" B4.
"Events" A5 - Event 3 should be placed in "2018" G3. This is because the date in "2018" H3 matches the date in "Events" B5 and so forth.

Thank you in advance for your help.

Mumps · Dec 18th 2018

Are the dates in the "Events" sheet always consecutive and sorted from oldest to newest?

cpereznj · Dec 18th 2018

Yes, the events are sequenced based on their dates, oldest to newest. All the events in the "Events" sheet should be added as a comment on the other sheets.

Mumps · Dec 18th 2018

Try this macro. Because the "Events" sheet contains years 2018 to 2020, you will either have to add a 2020 sheet or delete column D. Otherwise the macro will generate an error.

Code

Sub AddComments()
    Application.ScreenUpdating = False
    Dim lCol As Long, srcWS As Worksheet, desWS As Worksheet, rng As Range, rYear As Range, LastRow As Long, lDay As Long, x As Long: x = 1
    Set srcWS = Sheets("Events")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lDay = Day(srcWS.Range("B3")) + 2
    lCol = srcWS.Cells(2, Columns.Count).End(xlToLeft).Column
    For Each rYear In srcWS.Range(srcWS.Cells(2, 2), srcWS.Cells(2, lCol))
        Set desWS = Sheets(CStr(rYear.Value))
        For Each rng In srcWS.Range(srcWS.Cells(3, rYear.Column), srcWS.Cells(LastRow, rYear.Column))
            With desWS.Cells(lDay, x)
                If Not .Comment Is Nothing Then .Comment.Delete
                .AddComment srcWS.Cells(rng.Row, 1).Value
            End With
            x = x + 3
        Next rng
        x = 1
    Next rYear
    Application.ScreenUpdating = True
End Sub

Display More

cpereznj · Dec 18th 2018

Thank you Mumps for getting a solution so quickly.. I tried the code and noticed the comments are added to row 3 only in the 2018, 2019 and 2020 sheets. Is there a way the comments can actually be placed in the Day cell corresponding to the Event date? The calendar is setup in a vertical way. I'm attaching my test file in case you need it.

Mumps · Dec 18th 2018

Try:

Code

Sub AddComments()
    Application.ScreenUpdating = False
    Dim lCol As Long, srcWS As Worksheet, desWS As Worksheet, rng As Range, rYear As Range, LastRow As Long, lDay As Long, lMonth As Long
    Set srcWS = Sheets("Events")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = srcWS.Cells(2, Columns.Count).End(xlToLeft).Column
    For Each rYear In srcWS.Range(srcWS.Cells(2, 2), srcWS.Cells(2, lCol))
        Set desWS = Sheets(CStr(rYear.Value))
        For Each rng In srcWS.Range(srcWS.Cells(3, rYear.Column), srcWS.Cells(LastRow, rYear.Column))
            lDay = Day(srcWS.Cells(rng.Row, rYear.Column)) + 2
            lMonth = Month(srcWS.Cells(rng.Row, rYear.Column))
            Select Case lMonth
                Case Is = 1: lMonth = 2
                Case Is = 2: lMonth = 5
                Case Is = 3: lMonth = 8
                Case Is = 4: lMonth = 11
                Case Is = 5: lMonth = 14
                Case Is = 6: lMonth = 18
                Case Is = 7: lMonth = 21
                Case Is = 8: lMonth = 24
                Case Is = 9: lMonth = 27
                Case Is = 10: lMonth = 30
                Case Is = 11: lMonth = 33
                Case Is = 12: lMonth = 36
            End Select
            With desWS.Cells(lDay, lMonth).Offset(0, -1)
                If Not .Comment Is Nothing Then .Comment.Delete
                .AddComment srcWS.Cells(rng.Row, 1).Value
            End With
        Next rng
    Next rYear
    Application.ScreenUpdating = True
End Sub

Display More

cpereznj · Dec 19th 2018

Thank you Mumps for the updated code. That did the trick. I have one last question. Just realized that some events may have the same date. If that is the case, is there a way to append or concatenate both events in the same comment?

Mumps · Dec 19th 2018

Try:

Code

Sub AddComments()
    Application.ScreenUpdating = False
    Dim lCol As Long, srcWS As Worksheet, desWS As Worksheet, rng As Range, rYear As Range, LastRow As Long, lDay As Long, lMonth As Long
    Dim sAddr As String, foundDate As Range
    Set srcWS = Sheets("Events")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = srcWS.Cells(2, Columns.Count).End(xlToLeft).Column
    For Each rYear In srcWS.Range(srcWS.Cells(2, 2), srcWS.Cells(2, lCol))
        Set desWS = Sheets(CStr(rYear.Value))
        For Each rng In srcWS.Range(srcWS.Cells(3, rYear.Column), srcWS.Cells(LastRow, rYear.Column))
            Set foundDate = desWS.UsedRange.Offset(2, 0).Find(CDate(rng), LookIn:=xlFormulas, lookat:=xlWhole)
            If Not foundDate Is Nothing Then
                sAddr = foundDate.Address
                Do
                    With foundDate.Offset(0, -1)
                        If Not .Comment Is Nothing Then .Comment.Delete
                        .AddComment srcWS.Cells(rng.Row, 1).Value
                    End With
                    Set foundDate = desWS.UsedRange.Offset(2, 0).FindNext(foundDate)
                Loop While foundDate.Address <> sAddr
                sAddr = ""
            End If
        Next rng
    Next rYear
    Application.ScreenUpdating = True
End Sub

Display More

cpereznj · Dec 19th 2018

Thank you Mumps. Unfortunately, the updated code did not work. Only one event appears in the comment box. What can I do to merge events with the same date?

Mumps · Dec 19th 2018

Try:

Code

Sub AddComments()
    Application.ScreenUpdating = False
    Dim lCol As Long, srcWS As Worksheet, desWS As Worksheet, rng As Range, rYear As Range, LastRow As Long
    Dim sAddr As String, foundDate As Range
    Set srcWS = Sheets("Events")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = srcWS.Cells(2, Columns.Count).End(xlToLeft).Column
    For Each rYear In srcWS.Range(srcWS.Cells(2, 2), srcWS.Cells(2, lCol))
        Set desWS = Sheets(CStr(rYear.Value))
        desWS.Cells.ClearComments
        For Each rng In srcWS.Range(srcWS.Cells(3, rYear.Column), srcWS.Cells(LastRow, rYear.Column))
            Set foundDate = desWS.UsedRange.Offset(2, 0).Find(CDate(rng), LookIn:=xlFormulas, lookat:=xlWhole)
            If Not foundDate Is Nothing Then
                sAddr = foundDate.Address
                Do
                    With foundDate.Offset(0, -1)
                        If .Comment Is Nothing Then
                            .AddComment srcWS.Cells(rng.Row, 1).Value
                        Else
                            .Comment.Text .Comment.Text & vbLf & srcWS.Cells(rng.Row, 1).Value
                        End If
                    End With
                    Set foundDate = desWS.UsedRange.Offset(2, 0).FindNext(foundDate)
                Loop While foundDate.Address <> sAddr
                sAddr = ""
            End If
        Next rng
    Next rYear
    Application.ScreenUpdating = True
End Sub

Display More

cpereznj · Dec 19th 2018

That is great Mumps. Worked like a charm. Thank you so much. I noticed that you used the LookIn:=xlFormulas string. What if the 2018 and other year worksheets use formulas to fill the calendar days? See attached file. I'm using the formulas to make it easy to auto create the calendar with just entering the first of the year in 2018 A1 and so forth. Your code above does not work if I use the formulas.

Thank you again for all the help with this request.

Mumps · Dec 19th 2018

The attached file worked for me.

cpereznj · Dec 19th 2018

Hi Mumps, I see the problem. Please use the latest file I uploaded on this post. It should have two modules. The first module contains your code with the cases. The second module contains the code to merge events with the same date. This code does not work if the calendar dates in the 2018, 2019 and 2020 are based on formulas. Hopefully, you can replicate the issue on your end.
Thank you

Mumps · Dec 20th 2018

I don't quite understand. The code in the file you attached in Post #11 doesn't work as you said, but I tried the code below and it does work. Is it not working for you?

Code

Sub AddComments()
    Application.ScreenUpdating = False
    Dim lCol As Long, srcWS As Worksheet, desWS As Worksheet, rng As Range, rYear As Range, LastRow As Long
    Dim sAddr As String, foundDate As Range
    Set srcWS = Sheets("Events")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = srcWS.Cells(2, Columns.Count).End(xlToLeft).Column
    For Each rYear In srcWS.Range(srcWS.Cells(2, 2), srcWS.Cells(2, lCol))
        Set desWS = Sheets(CStr(rYear.Value))
        desWS.Cells.ClearComments
        For Each rng In srcWS.Range(srcWS.Cells(3, rYear.Column), srcWS.Cells(LastRow, rYear.Column))
            Set foundDate = desWS.UsedRange.Offset(2, 0).Find(CDate(rng), LookIn:=xlFormulas, lookat:=xlWhole)
            If Not foundDate Is Nothing Then
                sAddr = foundDate.Address
                Do
                    With foundDate.Offset(0, -1)
                        If .Comment Is Nothing Then
                            .AddComment srcWS.Cells(rng.Row, 1).Value
                        Else
                            .Comment.Text .Comment.Text & vbLf & srcWS.Cells(rng.Row, 1).Value
                        End If
                    End With
                    Set foundDate = desWS.UsedRange.Offset(2, 0).FindNext(foundDate)
                Loop While foundDate.Address <> sAddr
                sAddr = ""
            End If
        Next rng
    Next rYear
    Dim MyComments As Comment
    Dim xWs As Worksheet
    Dim LArea As Long
    For Each xWs In Application.ActiveWorkbook.Worksheets
        For Each MyComments In xWs.Comments
            With MyComments
                .Shape.AutoShapeType = msoShapeRoundedRectangle
                .Shape.TextFrame.AutoSize = True
                .Shape.TextFrame.Characters.Font.Name = "Tahoma"
                .Shape.TextFrame.Characters.Font.Size = 8
                .Shape.TextFrame.Characters(1, nl).Font.Bold = True
                .Shape.TextFrame.Characters.Font.ColorIndex = 1
                .Shape.Line.ForeColor.RGB = RGB(0, 0, 0)
                .Shape.Line.BackColor.RGB = RGB(255, 255, 255)
                .Shape.Fill.Visible = msoTrue
                .Shape.Fill.ForeColor.RGB = RGB(255, 255, 0)
                '.Shape.Fill.OneColorGradient msoGradientDiagonalUp, 1, 0.23
            End With
        Next MyComments 'comment
    Next xWs ' worksheet
    Application.ScreenUpdating = True
End Sub

Display More

cpereznj · Dec 20th 2018

Your latest code works if the dates in the "Day" columns are manually entered. For example 01/01/2018. However, if I use formulas to calculate the dates then the code does not work. If each cell in the "Day" columns have formulas the code does not work.

Mumps · Dec 21st 2018

Could you please attach a copy of the file that is not working. De-sensitize it if necessary.

cpereznj · Dec 21st 2018

Hi Mumps, I'm attaching the file as requested. The file only has one module with your latest code to merge comments if they have the same date. I highlighted the events with the same date in the Events sheet. I also made a note in the 2018 sheet to show that the dates in the Date columns are based on formulas. The formulas are there to make it easier to fill the calendar based on the year.
Once again, thank you so much for your help on this project.

Mumps · Dec 21st 2018

Try:

Code

Sub AddComments()
    Application.ScreenUpdating = False
    Dim lCol As Long, srcWS As Worksheet, desWS As Worksheet, rng As Range, rYear As Range, LastRow As Long, nl As Long
    Dim sAddr As String, foundDate As Range
    Set srcWS = Sheets("Events")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = srcWS.Cells(2, Columns.Count).End(xlToLeft).Column
    For Each rYear In srcWS.Range(srcWS.Cells(2, 2), srcWS.Cells(2, lCol))
        Set desWS = Sheets(CStr(rYear.Value))
        desWS.Cells.ClearComments
        For Each rng In srcWS.Range(srcWS.Cells(3, rYear.Column), srcWS.Cells(LastRow, rYear.Column))
            If rng <> "" Then
                Set foundDate = desWS.UsedRange.Offset(2, 0).Find(What:=Format(rng.Value2, "d"), _
                    LookIn:=xlValues, LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False)
                If Not foundDate Is Nothing Then
                    sAddr = foundDate.Address
                    On Error Resume Next
                    Do
                        If foundDate = rng Then
                            With foundDate.Offset(0, -1)
                                If .Comment Is Nothing Then
                                    .AddComment srcWS.Cells(rng.Row, 1).Value
                                Else
                                    .Comment.Text .Comment.Text & vbLf & srcWS.Cells(rng.Row, 1).Value
                                End If
                            End With
                        End If
                        Set foundDate = desWS.UsedRange.Offset(2, 0).FindNext(foundDate)
                    Loop While foundDate.Address <> sAddr
                    sAddr = ""
                End If
            End If
        Next rng
    Next rYear
    Dim MyComments As Comment
    Dim xWs As Worksheet
    Dim LArea As Long
    For Each xWs In Application.ActiveWorkbook.Worksheets
        For Each MyComments In xWs.Comments
            With MyComments
                .Shape.AutoShapeType = msoShapeRoundedRectangle
                .Shape.TextFrame.AutoSize = True
                .Shape.TextFrame.Characters.Font.Name = "Tahoma"
                .Shape.TextFrame.Characters.Font.Size = 8
                .Shape.TextFrame.Characters(1, nl).Font.Bold = True
                .Shape.TextFrame.Characters.Font.ColorIndex = 1
                .Shape.Line.ForeColor.RGB = RGB(0, 0, 0)
                .Shape.Line.BackColor.RGB = RGB(255, 255, 255)
                .Shape.Fill.Visible = msoTrue
                .Shape.Fill.ForeColor.RGB = RGB(255, 255, 0)
                '.Shape.Fill.OneColorGradient msoGradientDiagonalUp, 1, 0.23
            End With
        Next MyComments 'comment
    Next xWs ' worksheet
    Application.ScreenUpdating = True
End Sub

Display More

cpereznj · Dec 26th 2018

That did it Mumps. Thank you so much for your help on this project.

Mumps · Dec 26th 2018

My pleasure.

How to auto add comments based on date on separate sheet

Participate now!

Share

Users Viewing This Thread