VBA multi email help

[morleyja]

Good Morning all,

I have never used VBA but understand I can use it to send multiple emails from an excel spreadsheet using the click of a button. I want to generate multiple emails from the data in a spreadsheet in picture Excel Template 1

The VBA coding I have so far is follows:

Private Sub SendEmailReminders_Click()

Dim cd As Worksheet
Set cd = ThisWorkbook.Sheets("Excel template 1")
Dim i As Integer

Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Dim Link As String
On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
Link = Link
xMailBody = "Dear Owner Name" & vbNewLine & vbNewLine & _
"The contract 'Contract ID' is currently within 180 days of expiration" & vbNewLine & vbNewLine & _
"Please can you update the tracker on the Link below to show what progress has been made in the contract renewal/tender process" & vbNewLine & vbNewLine & _
" " & Link & " " & vbNewLine & _
"Many Thanks"
On Error Resume Next
With xOutMail
.Display 'or use .Send
.Body = xMailBody & vbCrLf & .Body
.To = Range("AX3").Value
.CC = ""
.BCC = "emailmanager@email.co.uk"
.Subject = "Contract Reminder Owner Name"

End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub

This generates 1 email to display as per the picture template email.

What I am struggling with is:

Generating multiple emails for each line where status column = Needs Attention
Pulling the contract ID from the spreadsheet into the subject line
Pulling the owner name into the email body for each line
Pulling the contract ID into the body for each line

The rest I am happy with but if you could help this would be very much appreciated

 

[John_w]

Try this - I've modified your macro to loop through the rows in the sheet and read the appropriate cells into the emails.

Private Sub SendEmailReminders_Click()

    Dim cd As Worksheet
    Dim lastRow As Long, r As Long
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Dim Link As String
    
    Set cd = ThisWorkbook.Sheets("Excel template 1")
    lastRow = cd.Cells(cd.Rows.Count, "A").End(xlUp).Row
    
    Set xOutApp = CreateObject("Outlook.Application")
    
    For r = 2 To lastRow
    
        If cd.Cells(r, "E").Value = "Needs Attention" Then
        
            Set xOutMail = xOutApp.CreateItem(0)
            Link = "https://www.mrexcel.com"
            xMailBody = "Dear " & cd.Cells(r, "C").Value & vbNewLine & vbNewLine & _
                        "The contract '" & cd.Cells(r, "A").Value & "' is currently within 180 days of expiration" & vbNewLine & vbNewLine & _
                        "Please can you update the tracker on the Link below to show what progress has been made in the contract renewal/tender process" & vbNewLine & vbNewLine & _
                        Link & vbNewLine & _
                        "Many Thanks"
                        
            On Error Resume Next
            With xOutMail
                .Display 'or use .Send
                .Body = xMailBody & vbCrLf & .Body
                .To = cd.Cells(r, "D").Value
                .CC = ""
                .BCC = "emailmanager@email.co.uk"
                .Subject = "Contract Reminder " & cd.Cells(r, "A").Value
            End With
            On Error GoTo 0
            
        End If
        
    Next
    
    Set xOutMail = Nothing
    Set xOutApp = Nothing
    
End Sub