Automated emails based on data in Excel sheet

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