Hi, I've searched and found threads related to the issue I'm having, however I've been unable to adapt the code to suit my needs. The current code I'm using is a copy from a website, as I'm still trying to get my head around VBA.

I have created an excel 2010 spreadsheet that includes nine columns with dates (the original sheet has several hundred rows). The purpose of the sheet is to track access cards that have been issued to staff, associates and athletes. To gain access to the department's facilities, various certificates (current) have to be provided, therefore dates will expire at different times. I have set conditional formatting for the dates due to expire in 30 days, and those that have already expired.

Because the register is fairly large in size, I would like a macro that would enable the user to press a button that will search across the nine columns for dates due to expire in 30 days and create a reminder email to send to the cardholder (individual emails). The email should only show the type of certificate (as per header) and the date it will expire, and a date that documents are to be provided by.

I’ve attached a sample file to give a clearer picture of the type of help I need. I hope I’ve made myself clear enough and have complied with the forum rules. **having probs with upload**

Thanks for any help I can get.

Sub SendEmail()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    
    Dim strbody As String
For Each cell In Range("E3:L5")
    strbody = strbody & cell.Value & vbNewLine
Next

    For Each cell In Columns("W").Cells.SpecialCells(xlCellTypeConstants) 'checks email address column
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "AA").Value) = "yes" Then 'sends email if "yes" in column

            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "QAS Access - Renewal Notice"
                '.Body = "Hi " & Cells(cell.Row, "B").Value _
                      & vbNewLine & vbNewLine & _
                        "This is a reminder that your certifications are due to expire, " & _
                        "and we need current documents"
                .Body = "Dear " & Cells(cell.Row, "B").Value & vbNewLine & vbNewLine & strbody
                'You can also add files like this:
                '.Attachments.Add ("C:\test.txt")
                .Display  'Or use Send.
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub