Automated emails based on data in Excel sheet - excel

Question

I need to send and email based on the expiry date of different machines.
I want to include all the expired machines in one email, as opposed to multiple emails.
The Excel sheet includes expiration date in column "I", the name of the machine in column "B", and has a function that calculates if my machines are "calibrated", "expired", or "near expiration", in column "P".
Private Sub Workbook_Open()
Dim Instrument As String
Dim Status As String
Status = Range("P6").Value
If IsNull(Status) = True Then Exit Sub
If Status = "Expiring Soon" Then
Instrument = Range("B6").Value
Mail_Expiring_Soon_Outlook Instrument
End If
If Status = "Expired" Then
Instrument = Range("B6").Value
Mail_Expired_Outlook Instrument
End If
End Sub
Sub Mail_Expiring_Soon_Outlook(Instrument As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Attention" & vbNewLine & vbNewLine & _
"The " & Instrument & " calibration is due within 30 days." & vbNewLine & vbNewLine & _
"Please arrange calibration."
On Error Resume Next
With xOutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Calibration Due within 30 days"
.Body = xMailBody
.Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
Sub Mail_Expired_Outlook(Instrument As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Warning!" & vbNewLine & vbNewLine & _
"The " & Instrument & " calibration is expired." & vbNewLine & vbNewLine & _
"Please arrange calibration."
On Error Resume Next
With xOutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Warning! Calibration is Expired"
.Body = xMailBody
.Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub

Answer 1

If I've understood what you're aiming for, you could simply loop through all the rows adding machine names to one of two variables depending on the status.
You could use something like the following...
Private Sub Workbook_Open()
Dim ExpiringSoon As String
Dim Expired As String
Dim Subject As String
Dim Body As String
Dim Row As Long
' Loop through rows, from row 2 until the last used row in column B
For Row = 2 To Cells(Rows.Count, "B").End(xlUp).Row
Select Case Cells(Row, "P")
Case "Expiring Soon"
ExpiringSoon = ExpiringSoon & Cells(Row, "B") & vbNewLine
Case "Expired"
Expired = Expired & Cells(Row, "B") & vbNewLine
End Select
Next
If ExpiringSoon <> "" Then
Subject = "Calibration Due within 30 days"
Body = "Attention" & vbNewLine & vbNewLine & _
"Calibration is due within 30 days for the following machines:" & vbNewLine & _
ExpiringSoon & vbNewLine & _
"Please arrange calibration."
Send_Mail Subject, Body
End If
If Expired <> "" Then
Subject = "Warning! Calibration is Expired"
Body = "Warning!" & vbNewLine & vbNewLine & _
"Calibration is expired for the following machines:" & vbNewLine & _
Expired & vbNewLine & _
"Please arrange calibration."
Send_Mail Subject, Body
End If
End Sub
Sub Send_Mail(Subject As String, Body As String)
On Error Resume Next
With CreateObject("Outlook.Application").CreateItem(0)
.Subject = Subject
.BodyFormat = 1
.Body = Body
.Display
End With
End Sub

Answer 2

Private Sub Workbook_Open()
Dim Instrument1 As String
Dim Instrument2 As String
Dim ws As Worksheet
Dim Status As String
Set ws = Sheets("DAQ Fault Log")
lr = ws.Range("A" & Rows.Count).End(xlUp).Row
' MsgBox "This code ran at Excel start!"
' On Error Resume Next
' If Target.Cells.Count > 1 Then Exit Sub
counter1 = 0
counter2 = 0
On Error Resume Next
For i = 2 To lr
Status = ws.Range("P" & i).Value
If Status = "Expiring Soon" Then
Instrument1 = Instrument1 & ws.Range("B" & i).Value & ", "
counter1 = counter1 + 1
End If
If Status = "Expired" Then
Instrument2 = Instrument2 & ws.Range("B" & i).Value & ", "
counter2 = counter2 + 1
End If
Next i
If counter1 > 0 And counter1 = 1 Then Mail_Expiring_Soon_Outlook Left(Instrument1, Len(Instrument1) - 2)
If counter1 > 0 And counter1 > 1 Then Mail_Expiring_Soon_Outlook Left(Instrument1, Len(Instrument1) - 1)
If counter2 > 0 And counter2 = 1 Then Mail_Expired_Outlook Left(Instrument2, Len(Instrument2) - 2)
If counter2 > 0 And counter2 > 1 Then Mail_Expired_Outlook Left(Instrument2, Len(Instrument2) - 1)
End Sub
Sub Mail_Expiring_Soon_Outlook(Instrument1 As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Attention" & vbNewLine & vbNewLine & _
"The " & Instrument1 & " calibration is due within 30 days." & vbNewLine & vbNewLine & _
"Please arrange calibration."
On Error Resume Next
With xOutMail
.to = ""
.CC = ""
.BCC = ""
.Subject = "Calibration Due within 30 days"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
Sub Mail_Expired_Outlook(Instrument2 As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Warning!" & vbNewLine & vbNewLine & _
"The " & Instrument2 & " calibration is expired." & vbNewLine & vbNewLine & _
"Please arrange calibration."
On Error Resume Next
With xOutMail
.to = ""
.CC = ""
.BCC = ""
.Subject = "Warning! Calibration is Expired"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub