Calender Update Script not working

[anuradhagrewal]

Hi
This is a calendar update which I have made
I am not able to update all the cells in real time when I input the value in the data worksheet against a given date.
I want the given event to get updated next to the date in the calendrer worksheet
Can you kindly please guide me what wrong with the script

Sub UpdateCalendarQwen()
    Dim dataSheet As Worksheet
    Dim calendarSheet As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim eventDate As Date
    Dim eventText As String
    Dim monthName As String
    Dim dayNumber As Integer
    Dim foundMonth As Range
    Dim foundDay As Range
    Dim searchRange As Range
    Dim monthRow As Long
    
    ' Set worksheets
    Set dataSheet = ThisWorkbook.Sheets("Data")
    Set calendarSheet = ThisWorkbook.Sheets("Calendar1")
    
    ' Find the last row in the Data sheet
    lastRow = dataSheet.Cells(dataSheet.Rows.Count, 2).End(xlUp).Row
    
    ' Loop through each row in the Data sheet
    For i = 2 To lastRow ' Assuming row 1 contains headers
        On Error Resume Next ' Skip errors for invalid dates
        eventDate = dataSheet.Cells(i, 2).Value ' Column B: Date
        On Error GoTo 0
        
        ' Skip if date is invalid
        If IsDate(eventDate) Then
            eventText = dataSheet.Cells(i, 3).Value ' Column C: Event
            
            ' Skip if no event is entered
            If Trim(eventText) <> "" Then
                monthName = Format(eventDate, "MMMM") ' Get month name (e.g., "April")
                dayNumber = day(eventDate) ' Get day number
                
                Debug.Print "Processing date: " & eventDate & ", Month: " & monthName & ", Day: " & dayNumber
                
                ' Find the month header in Calendar1 sheet
                Set foundMonth = calendarSheet.Cells.Find(What:=monthName, _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    MatchCase:=False, _
                    SearchFormat:=False)
                
                If foundMonth Is Nothing Then
                    Debug.Print "Month not found: " & monthName
                    ' Try finding with leading/trailing spaces
                    Set foundMonth = calendarSheet.Cells.Find(What:=Trim(monthName), _
                        LookIn:=xlValues, _
                        LookAt:=xlPart, _
                        MatchCase:=False)
                    If Not foundMonth Is Nothing Then
                        Debug.Print "Found month with partial match: " & monthName
                    End If
                Else
                    Debug.Print "Found month: " & monthName & " at " & foundMonth.Address
                    
                    ' Define search range from month row to next month or end of sheet
                    monthRow = foundMonth.Row
                    Dim nextMonth As Range
                    Set nextMonth = calendarSheet.Cells.FindNext(After:=foundMonth)
                    
                    Dim endRow As Long
                    If Not nextMonth Is Nothing And nextMonth.Row > monthRow Then
                        endRow = nextMonth.Row - 1
                    Else
                        endRow = calendarSheet.UsedRange.Rows.Count
                    End If
                    
                    ' Search for day number in the month's section
                    Set foundDay = calendarSheet.Range(calendarSheet.Cells(monthRow + 1, 1), _
                                                      calendarSheet.Cells(endRow, 31)) _
                                    .Find(What:=dayNumber, _
                                          LookIn:=xlValues, _
                                          LookAt:=xlWhole, _
                                          SearchOrder:=xlByRows)
                    
                    If foundDay Is Nothing Then
                        ' Try finding day as text
                        Set foundDay = calendarSheet.Range(calendarSheet.Cells(monthRow + 1, 1), _
                                                          calendarSheet.Cells(endRow, 31)) _
                                        .Find(What:=CStr(dayNumber), _
                                              LookIn:=xlValues, _
                                              LookAt:=xlWhole, _
                                              SearchOrder:=xlByRows)
                        Debug.Print "Day not found as number, trying as text: " & dayNumber
                    End If
                    
                    If foundDay Is Nothing Then
                        Debug.Print "Day not found: " & dayNumber & " in month " & monthName
                    Else
                        Debug.Print "Found day: " & dayNumber & " at " & foundDay.Address
                        
                        ' Write event text below the day number
                        calendarSheet.Cells(foundDay.Row + 1, foundDay.Column).Value = eventText
                    End If
                End If
            Else
                Debug.Print "Empty event text skipped for date: " & eventDate
            End If
        Else
            Debug.Print "Invalid date skipped: " & dataSheet.Cells(i, 2).Value
        End If
    Next i
    
    MsgBox "Calendar updated successfully!"
End Sub

 

[Sam_D_Ben]

Slighlty updated,

Sub UpdateCalendarQwen()
    Dim dataSheet   As Worksheet
    Dim calendarSheet As Worksheet
    Dim lastRow     As Long
    Dim i           As Long
    Dim eventDate   As Date
    Dim eventText   As String
    Dim monthName   As String
    Dim dayNumber   As Integer
    Dim foundMonth  As Range
    Dim foundDay    As Range
    Dim searchRange As Range
    Dim monthRow    As Long
    
    ' Set worksheets
    Set dataSheet = ThisWorkbook.Sheets("Data")
    Set calendarSheet = ThisWorkbook.Sheets("Calendar1")
    
    ' Find the last row in the Data sheet
    lastRow = dataSheet.Cells(dataSheet.Rows.Count, 2).End(xlUp).Row
    
    ' Loop through each row in the Data sheet
    For i = 2 To lastRow        ' Assuming row 1 contains headers
        On Error Resume Next        ' Skip errors for invalid dates
        eventDate = dataSheet.Cells(i, 2).Value        ' Column B: Date
        On Error GoTo 0
        
        ' Skip if date is invalid
        If IsDate(eventDate) Then
            eventText = dataSheet.Cells(i, 3).Value        ' Column C: Event
            
            ' Skip if no event is entered
            If Trim(eventText) <> "" Then
                monthName = Format(eventDate, "MMMM")        ' Get month name (e.g., "April")
                dayNumber = Day(eventDate)        ' Get day number
                
                Debug.Print "Processing date: " & eventDate & ", Month: " & monthName & ", Day: " & dayNumber
                
                ' Find the month header in Calendar1 sheet
                Set foundMonth = calendarSheet.Range("B:B").Find(What:=monthName, _
                LookIn:=xlValues, _
                LookAt:=xlWhole, _
                MatchCase:=False, _
                SearchFormat:=False)
                
                If foundMonth Is Nothing Then
                    Debug.Print "Month Not found: " & monthName
                    ' Try finding with leading/trailing spaces
                    Set foundMonth = calendarSheet.Cells.Find(What:=Trim(monthName), _
                    LookIn:=xlValues, _
                    LookAt:=xlPart, _
                    MatchCase:=False)
                    If Not foundMonth Is Nothing Then
                        Debug.Print "Found month With partial match: " & monthName
                    End If
                Else
                    Debug.Print "Found month: " & monthName & " at " & foundMonth.Address
                    
                    ' Define search range from month row to next month or end of sheet
                    monthRow = foundMonth.Row
                    
                    ' ? Normalize (clean) the calendar day block: B to H, 6 rows below month
                    With calendarSheet
                        .Range(.Cells(monthRow + 1, 2), .Cells(monthRow + 6, 8)).Value = _
                                               .Range(.Cells(monthRow + 1, 2), .Cells(monthRow + 6, 8)).Value
                    End With
                    
                    Dim nextMonth As Range
                    Set nextMonth = calendarSheet.Cells.FindNext(After:=foundMonth)
                    
                    Dim endRow As Long
                    If Not nextMonth Is Nothing And nextMonth.Row > monthRow Then
                        endRow = nextMonth.Row - 1
                    Else
                        endRow = calendarSheet.UsedRange.Rows.Count
                    End If
                    
                    ' Search for day number in the month's section
                    Set foundDay = calendarSheet.Range(calendarSheet.Cells(monthRow + 1, 2), _
                    calendarSheet.Cells(endRow, 8)) _
                    .Find(What:=dayNumber, _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows)
                    
                    If foundDay Is Nothing Then
                        ' Try finding day as text
                        Set foundDay = calendarSheet.Range(calendarSheet.Cells(monthRow + 1, 1), _
                        calendarSheet.Cells(endRow, 31)) _
                        .Find(What:=CStr(dayNumber), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows)
                        Debug.Print "Day Not found As number, trying As text: " & dayNumber
                    End If
                    
                    If foundDay Is Nothing Then
                        Debug.Print "Day Not found: " & dayNumber & " in month " & monthName
                    Else
                        Debug.Print "Found day: " & dayNumber & " at " & foundDay.Address
                        
                        ' Write event text below the day number
                        calendarSheet.Cells(foundDay.Row + 1, foundDay.Column).Value = eventText
                    End If
                End If
            Else
                Debug.Print "Empty Event Text skipped For date: " & eventDate
            End If
        Else
            Debug.Print "Invalid Date skipped: " & dataSheet.Cells(i, 2).Value
        End If
    Next i
    
    MsgBox "Calendar updated successfully!"
End Sub

 

[Sam_D_Ben]

Also, please correct any spelling errors in the month names and ensure that the date format is consistent throughout.

 

[MikeVol]

Hello @anuradhagrewal.
Another option and also a sample file are attached at the link. The code will work only in this format. In general, you will see changes in the file.

Option Explicit

Sub UpdateCalendarMikeVol()
    Dim i           As Long
    Dim eventDate   As Date
    Dim eventText   As String
    Dim firstOfMonth As Date
    Dim specificDate As Date
    Dim foundMonth  As Range
    Dim foundDay    As Range
    Dim searchRange As Range
    Dim cell        As Range

    Dim dataSheet   As Worksheet
    Set dataSheet = ThisWorkbook.Worksheets("Data")

    Dim calendarSheet As Worksheet
    Set calendarSheet = ThisWorkbook.Worksheets("Calendar1")

    Dim lastRow     As Long
    lastRow = dataSheet.Cells(dataSheet.Rows.Count, "B").End(xlUp).Row
    Application.ScreenUpdating = False

    For i = 3 To lastRow

        If IsDate(dataSheet.Cells(i, 2).Value) Then
            eventDate = CDate(dataSheet.Cells(i, 2).Value)
            eventText = Trim(dataSheet.Cells(i, 3).Value)

            If eventText <> "" Then
                firstOfMonth = DateSerial(Year(eventDate), Month(eventDate), 1)

                specificDate = DateSerial(Year(eventDate), Month(eventDate), Day(eventDate))

                Set foundMonth = calendarSheet.Columns("A").Find(What:=firstOfMonth, _
                        LookIn:=xlFormulas, _
                        LookAt:=xlWhole, _
                        MatchCase:=False)

                If Not foundMonth Is Nothing Then

                    Set searchRange = calendarSheet.Range(calendarSheet.Cells(foundMonth.Row + 1, 1), _
                            calendarSheet.Cells(foundMonth.Row + 12, 8))

                    Set foundDay = searchRange.Find(What:=specificDate, _
                            LookIn:=xlFormulas, _
                            LookAt:=xlWhole, _
                            MatchCase:=False)

                    If foundDay Is Nothing Then

                        For Each cell In searchRange

                            If IsDate(cell.Value) And cell.Value = specificDate Then
                                Set foundDay = cell
                                Exit For
                            End If

                        Next cell

                    End If

                    If Not foundDay Is Nothing Then
                        calendarSheet.Cells(foundDay.Row + 1, foundDay.Column).Value = eventText
                    Else
                        Debug.Print "Date " & specificDate & " not found in range!"
                    End If

                Else
                    Debug.Print "Month " & firstOfMonth & " not found in column A!"
                End If

            End If

        End If

    Next i

    Application.ScreenUpdating = True
    MsgBox "Calendar updated successfully!", vbInformation
End Sub

I hope my solution will help you. Good luck.

 

[anuradhagrewal]

Hi Guys
Thanks a ton for the revised code and the spell check
However when I cleared the contents and tried to update the code its does not update
You can have a look at the file as I have uploaded it here and kindly please suggest what to do
Also I want to make the calender1 sheet dynamic wherein whatever changes I make in the data worksheet be it modifications or deletions the same be automatically be updated in the output calendar
Kindly please guide

 

[Sam_D_Ben]

This is your file: it is working for me. Please check.

Raw Calender.xlsm

drive.google.com

 

[MikeVol]

Hi @anuradhagrewal. You are not attentive, very much. It is necessary to observe the formatting of cells with dates! Look in my file how the dates are written and how you enter the dates. Didn't you see the difference? That's why the macros that we provided you don't work. Good luck.

P.S. The code in the my file works correctly for me.

 

[anuradhagrewal]

Hi @anuradhagrewal. You are not attentive, very much. It is necessary to observe the formatting of cells with dates! Look in my file how the dates are written and how you enter the dates. Didn't you see the difference? That's why the macros that we provided you don't work. Good luck.

P.S. The code in the my file works correctly for me.

Ohh Mike dont be so condescending
you are such a sweet heart
Can I request you to please make this file such that the data is updated real time and I dont have to run the macros
thanks a ton

 

[MikeVol]

Ohhh... Put this code in worksheet module "Data" in the my file which i provide for you. Now when you will enter data in column "C" in the worksheet "Data" automatically will be updated entering data to worksheet Calendar1.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Not Intersect(Target, Me.Range("C3:C" & Me.Rows.Count)) Is Nothing Then
        Application.EnableEvents = False
        On Error Resume Next
        UpdateCalendarMikeVol
        On Error GoTo 0
        Application.EnableEvents = True
    End If

End Sub

Good luck.