send auto email work anniversary

[kerm007]

hello
how can my HR girls auto send email to all when its the work anniversary of some one from an excel sheet populated with the name and the anniversay date of an employee ?
Thanks

 

[Wookiee]

I redid the whole thing, so I'll attempt to lay out the entire construction in one well-worded go. Wish me luck!

[WORKSHEET SET UP]

Cell B2 is a named range (nrToday) and its formula is

=TODAY()

The data table is named tblX with its headers on Row 3.

Column A contains employee names, Column B shows their hire dates, and Column C lists their email addresses.

Columns D and E are used to calculate whether the people have an anniversary and how many years they've been with the company.

The formula for Cell D4 is

=IF(AND(MONTH(B4)=MONTH(nrToday),DAY(B4)=DAY(nrToday)),"Anniversary","")

The formula for Cell E4 is

=DATEDIF([@Hired],nrToday,"Y")

[CODE SETUP]

From the VB Editor, paste this code into the ThisWorkbook object:

Option Explicit

Private Sub Workbook_Open()

Dim rngCell     As Range
Dim strMessage  As String


For Each rngCell In Range("tblX[Name]")

  If rngCell.Offset(0, 3) = "Anniversary" Then

    strMessage = "Congratulations, yo!<br><br>" & _
      "We are so totally chuffed to have " & _
      "you working with us.<br><br>Happy " & _
      Addth(rngCell.Offset(0, 4).Value) & _
      " Work Anniversary!"

    Call Email _
      (rngCell.Offset(0, 2), "Happy Anniversary!", strMessage)

    strMessage = ""

  End If

Next rngCell

End Sub

And paste these codes into Module1:

Option Explicit

Function Addth(pNumber As String) As String
'Updateby20141027
'Function Posted At:
'https://www.extendoffice.com/documents/excel/2167-excel-convert-cardinal-to-ordinal.html


Select Case CLng(VBA.Right(pNumber, 1))

  Case 1:  Addth = pNumber & "st"
  Case 2:  Addth = pNumber & "nd"
  Case 3:  Addth = pNumber & "rd"
  Case Else: Addth = pNumber & "th"

End Select

Select Case VBA.CLng(VBA.Right(pNumber, 2))

  Case 11, 12, 13:  Addth = pNumber & "th"

End Select

End Function


Sub Email _
  (sTo As String, sSub As String, _
   sHTML As String, Optional sAttach As Variant, _
   Optional sAction As String = "Display", _
   Optional sCCs As String, Optional sSender As String)
'v1.49   31 Mar 2023
'https://www.RONDEBRUIN.nl/win/s1/outlook/signature.htm
'with appreciation to ChatGPT for help with the attachment
'logic


'Declare Variables
Dim lngLoop  As Long
Dim olApp    As Object
Dim olMsg    As Object
Dim arrEh    As Variant

'Create Email Message
Set olApp = CreateObject("Outlook.Application")
Set olMsg = olApp.CreateItem(0)

On Error Resume Next

  Set olApp = GetObject(, "Outlook.Application")
 
  If olApp Is Nothing Then _
    Set olApp = CreateObject("Outlook.Application")
 
  Set olMsg = olApp.CreateItem(0)
 
  With olMsg
 
    .Display

    If sSender <> "" Then

      .SentOnBehalfOfName = sSender

    End If

    .To = sTo
    .CC = sCCs
    .HTMLBody = sHTML & .HTMLBody
    .Subject = sSub

    If Not IsMissing(sAttach) And Not IsNull(sAttach) Then

      If Not IsArray(sAttach) Then

        .Attachments.Add sAttach
        GoTo Utah

      End If
  
      For lngLoop = LBound(sAttach) To UBound(sAttach)
    
        .Attachments.Add sAttach(lngLoop)
    
      Next lngLoop

Utah:
    End If
  
    If sAction = "Display" Then
  
      .Display
  
    ElseIf sAction = "Send" Then
  
      .Send
  
    End If
 
  End With
On Error GoTo 0

'Clear Set Variables
Set olApp = Nothing
Set olMsg = Nothing


End Sub

I tested it out and it all worked, so once you plug in your employee data, save and close the file, it should work nicely the next time someone opens the file.

 

[Wookiee]

If you set up your spreadsheet something along the lines of what I have prepared, you can do that.

First, I created a named range (a cell with the TODAY formula in it so it will always reflect the current date).

Next, I made a table with employee names, dates of birth, email addresses, and an extra column to identify any birthday people. Here's the formula for comparing birthdates:

=IF(AND(MONTH(B4)=MONTH(nrToday),DAY(B4)=DAY(nrToday)),"Birthday person!","")

Next, I crafted this macro which will launch upon opening the file:

Private Sub Workbook_Open()

Dim rngCell As Range

For Each rngCell In Range("tblPeeps[Name]")

  If rngCell.Offset(0, 3) = "Birthday person!" Then

    Call Email _
      (rngCell.Offset(0, 2), "Happy Birthday!", "For you're a jolly good fellow, folderol lorem ipsum!")

  End If

Next rngCell

End Sub

You will need to either add a code module or include this macro in your existing one for the previous code to function:

Sub Email _
  (sTo As String, sSub As String, _
   sHTML As String, Optional sAttach As Variant, _
   Optional sAction As String = "Display", _
   Optional sCCs As String, Optional sSender As String)
'v1.49   31 Mar 2023
'Crafted by Ron DeBruin, Wookiee at MrExcel, and ChatGPT
'https://www.RONDEBRUIN.nl/win/s1/outlook/signature.htm



'Declare Variables
Dim lngLoop  As Long
Dim olApp    As Object
Dim olMsg    As Object
Dim arrEh    As Variant

'Create Email Message
Set olApp = CreateObject("Outlook.Application")
Set olMsg = olApp.CreateItem(0)

On Error Resume Next

  Set olApp = GetObject(, "Outlook.Application")
  
  If olApp Is Nothing Then _
    Set olApp = CreateObject("Outlook.Application")
  
  Set olMsg = olApp.CreateItem(0)
  
  With olMsg
  
    .Display

    If sSender <> "" Then

      .SentOnBehalfOfName = sSender

    End If

    .To = sTo
    .CC = sCCs
    .HTMLBody = sHTML & .HTMLBody
    .Subject = sSub

    If Not IsMissing(sAttach) And Not IsNull(sAttach) Then

      If Not IsArray(sAttach) Then

        .Attachments.Add sAttach
        GoTo Utah

      End If
    
      For lngLoop = LBound(sAttach) To UBound(sAttach)
      
        .Attachments.Add sAttach(lngLoop)
      
      Next lngLoop

Utah:
    End If
    
    If sAction = "Display" Then
    
      .Display
    
    ElseIf sAction = "Send" Then
    
      .Send
    
    End If
  
  End With
On Error GoTo 0

'Clear Set Variables
Set olApp = Nothing
Set olMsg = Nothing


End Sub

 

[kerm007]

hello thanks
i did one with instruction but its not working so far
will continue to test
Thanks

 

[Wookiee]

hello thanks
i did one with instruction but its not working so far
will continue to test
Thanks

I re-read my message and it occurred to me that I failed to mention that the Workbook_Open macro needs to be put in the worksheet itself, not the code module. I hope that helps.

 

[Joe4]

I re-read my message and it occurred to me that I failed to mention that the Workbook_Open macro needs to be put in the worksheet itself, not the code module. I hope that helps.

To be clear, it needs to go in the "ThisWorkbook" module, not any of the Sheet modules or in any General module that you insert.

 

[kerm007]

ok i insert formula into the B1,2 cell
the first vba code into this workbook
where do i insert the second VBA?
for now even the date is not working
Thanks helping

 

[kerm007]

also how can i adjust it to be the employment birthday like happy 2 years etc ?

 

[Wookiee]

I apologize for my poorly worded response previously. I meant workbook but typed worksheet like a dipsheet.

I hope this helps clarify the location of the codes.

 

[kerm007]

i will check thanks for all this