Birthday Reminder

[chand1230]

I want to make a birthday reminder with a popup message box, the below code works perfect if the birthday is between two dates i.e. if the birthday date is between today and next 14 days, but if there is no birthday in next 15 days than the message box popup does not work.

I want the message popup to display that "There are no Birthday in Next 15 Days" and it should display the popup only once.

Thanks in advance.

Sub Reminder()

Dim LR As Long, i As Long, msg As String


With Sheets("Sheet1")
  LR = .Range("c" & Rows.Count).End(xlUp).Row
  For i = 1 To LR
  If IsDate(.Range("c" & i)) Then
  'If .Range("A" & i).Value - Date < 30 Then
  
  If .Range("c" & i).Value >= Date And .Range("c" & i).Value <= Date + 14 Then
  
  'msg = msg & .Range("A" & i).Value & vbTab & vbTab & Format(.Range("c" & i).Value, "ddd-dd-mmm-yyyy") & vbCrLf  '& vbCrLf
  msg = msg & .Range("A" & i).Value & " Birthday is on " & Format(.Range("c" & i).Value, "ddd-dd-mmm-yyyy") & vbCrLf  '& vbCrLf
  End If
  End If
  Next i
End With
If msg <> "" Then MsgBox prompt:=Left(msg, Len(msg) - 1), Title:="Upcoming Birthday", Buttons:=vbInformation
End Sub

 

[Hui]

Sub Reminder()

Dim LR As Long, i As Long, msg As String


With Sheets("Sheet1")
  LR = .Range("c" & Rows.Count).End(xlUp).Row
  For i = 1 To LR
  If IsDate(.Range("c" & i)) Then
  'If .Range("A" & i).Value - Date < 30 Then  
  If .Range("c" & i).Value >= Date And .Range("c" & i).Value <= Date + 14 Then
  
  'msg = msg & .Range("A" & i).Value & vbTab & vbTab & Format(.Range("c" & i).Value, "ddd-dd-mmm-yyyy") & vbCrLf  '& vbCrLf  
msg = msg & .Range("A" & i).Value & " Birthday is on " & Format(.Range("c" & i).Value, "ddd-dd-mmm-yyyy") & vbCrLf  '& vbCrLf 
else
msg ="There are no birthdays in the next 15 days"

 End If

  End If
  Next i
End With
If msg <> "" Then MsgBox prompt:=Left(msg, Len(msg) - 1), Title:="Upcoming Birthday", Buttons:=vbInformation
End Sub

 

[chand1230]

Sub Reminder()

Dim LR As Long, i As Long, msg As String


With Sheets("Sheet1")
  LR = .Range("c" & Rows.Count).End(xlUp).Row
  For i = 1 To LR
  If IsDate(.Range("c" & i)) Then
  'If .Range("A" & i).Value - Date < 30 Then 
  If .Range("c" & i).Value >= Date And .Range("c" & i).Value <= Date + 14 Then
 
  'msg = msg & .Range("A" & i).Value & vbTab & vbTab & Format(.Range("c" & i).Value, "ddd-dd-mmm-yyyy") & vbCrLf  '& vbCrLf 
msg = msg & .Range("A" & i).Value & " Birthday is on " & Format(.Range("c" & i).Value, "ddd-dd-mmm-yyyy") & vbCrLf  '& vbCrLf
else
msg ="There are no birthdays in the next 15 days"

End If

  End If
  Next i
End With
If msg <> "" Then MsgBox prompt:=Left(msg, Len(msg) - 1), Title:="Upcoming Birthday", Buttons:=vbInformation
End Sub

Thank you Very much Hui this is what I wanted thanks a lot

 

[chand1230]

Thank you Very much Hui this is what I wanted thanks a lot

Sorry Hui,

It is not working properly it is displaying both messages when there are birthdays in dates

PFA for your reference, I have placed the data in two separate sheets

 

[Hui]

Whoops didn't look at all the code

try this:

Sub Reminder()

Dim LR As Long, i As Long, msg As String

'With Sheets("Sheet1")
With ActiveSheet

  LR = .Range("c" & Rows.Count).End(xlUp).Row
  For i = 1 To LR
  If IsDate(.Range("c" & i)) Then
  'If .Range("A" & i).Value - Date < 30 Then
   
  If .Range("c" & i).Value >= Date And .Range("c" & i).Value <= Date + 14 Then
   
  'msg = msg & .Range("A" & i).Value & vbTab & vbTab & Format(.Range("c" & i).Value, "ddd-dd-mmm-yyyy") & vbCrLf  '& vbCrLf
  msg = msg & .Range("A" & i).Value & " Birthday is on " & Format(.Range("c" & i).Value, "ddd-dd-mmm-yyyy") & vbCrLf  '& vbCrLf
  End If
  End If
  Next i
   
End With
If msg <> "" Then
  MsgBox prompt:=Left(msg, Len(msg) - 1), Title:="Upcoming Birthday", Buttons:=vbInformation
Else
  MsgBox prompt:="There are no Birthdays for the next 15 days", Title:="Upcoming Birthday", Buttons:=vbInformation
End If
End Sub

 

[chand1230]

Whoops didn't look at all the code

try this:

Sub Reminder()

Dim LR As Long, i As Long, msg As String

'With Sheets("Sheet1")
With ActiveSheet

  LR = .Range("c" & Rows.Count).End(xlUp).Row
  For i = 1 To LR
  If IsDate(.Range("c" & i)) Then
  'If .Range("A" & i).Value - Date < 30 Then
  
  If .Range("c" & i).Value >= Date And .Range("c" & i).Value <= Date + 14 Then
  
  'msg = msg & .Range("A" & i).Value & vbTab & vbTab & Format(.Range("c" & i).Value, "ddd-dd-mmm-yyyy") & vbCrLf  '& vbCrLf
  msg = msg & .Range("A" & i).Value & " Birthday is on " & Format(.Range("c" & i).Value, "ddd-dd-mmm-yyyy") & vbCrLf  '& vbCrLf
  End If
  End If
  Next i
  
End With
If msg <> "" Then
  MsgBox prompt:=Left(msg, Len(msg) - 1), Title:="Upcoming Birthday", Buttons:=vbInformation
Else
  MsgBox prompt:="There are no Birthdays for the next 15 days", Title:="Upcoming Birthday", Buttons:=vbInformation
End If
End Sub

Now this is perfect thank's a lot Hui