Sending an automatic email based on cell value - vba

Question

I have this code that I have cobbled together but, sadly I am stuck I can’t seem to work out how to only have the email addresses for overdue entries in the BCC.
I want it to create a single email to multiple email addresses from a list of emails that have a due date that is overdue and a previous email hasn't already been sent.
Sub Over_due()
Dim OutApp As Object
Dim OutMail As Object
Dim lLastRow As Long
Dim lRow As Long
Dim rng As Range
strbody = "Text goes here"
lLastRow = Cells(Rows.Count, 3).End(xlUp).Row
For lRow = 2 To lLastRow
If Cells(lRow, 6) <> "Email Sent" Then
If Cells(lRow, 5) <= Date Then
Set xOutlook = CreateObject("Outlook.Application")
Set xMailItem = xOutlook.CreateItem(0)
For Each rng In Range("C:C")
If rng.Value Like "*#*" Then
If xEmailAddr = "" Then
xEmailAddr = rng.Value
Else
xEmailAddr = xEmailAddr & ";" & rng.Value
End If
End If
Next
On Error Resume Next
With xMailItem
.To = ""
.CC = ""
.BCC = xEmailAddr
.Subject = Range("A1").Value
.HTMLBody = strbody
'.Attachments.Add
.Display
End With
MsgBox "E-mail successfully created", 64
Application.DisplayAlerts = False
Set Mail_Object = Nothing
Cells(lRow, 6) = "Sent email"
Cells(lRow, 7) = "" & Now()
End If
End If
Next
Set OutApp = Nothing
End Sub

Answer 1

I use a sub which automatically creates emails. and call it from various other subs - might come in handy:
Sub SendEmail(Optional ToAddresses As String, Optional CcAddresses As String, _
Optional BccAddresses As String, Optional Subject As String, _
Optional Body As String, Optional AttachFiles As Variant = False, Optional AutoSend As Boolean = False)
'RULES:
' Where there are multiple Addresses in ToAddresses, CCAddresses
' etc, they have to be separated by a semicolon
' AttachFiles should either be a string containing the full
' filename including the path, or (for multiple files) an array
' of same.
' Body can be HTML or just plain text.
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = ToAddresses
.CC = CcAddresses
.Bcc = BccAddresses
.Subject = Subject
If Body Like "*</*>*" Then
.HtmlBody = Body
Else
.Body = Body
End If
If Not AttachFiles = False Then
If IsArray(AttachFiles) Then
For x = LBound(AttachFiles) To UBound(AttachFiles)
.Attachments.Add (AttachFiles(x))
Next
Else
.Attachments.Add (AttachFiles)
End If
End If
If AutoSend = True Then
.Send
Else
.Display
End If
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
It's not totally my code, I adapted it from here.
It won't completely solve your problem, but it might condense it down to something simpler and more like:
Sub OverDue()
Dim strBody as String
Dim Row as Long
Dim lLastRow as Long
StrBody = "Text here"
lLastRow = UsedRange.Rows.Count
For a = 2 to lLastRow
If Cells(a, 6) <> "Email Sent" And Cells(a, 5)<= Date Then 'This checks each row to see if that person needs an email
' DO STUFF HERE
' Either Call the other sub separately each time
' (which can allow for more personalised messages, like a mail merge),
' or add the person's email address to a string and call the sub
' after the loop.
Next
End Sub
Over to you to work out the rest of the details though!!

Answer 2

I fixed your code like that
Sub Over_due()
Dim OutApp As Object
Dim OutMail As Object
Dim lLastRow As Long
Dim lRow As Long
Dim rng As Range
Dim strbody As String
Dim xOutlook
Dim xMailItem
Dim xEmailAddr
strbody = "Text goes here"
lLastRow = Cells(Rows.Count, 3).End(xlUp).Row
For lRow = 2 To lLastRow
If Cells(lRow, 6) <> "Email Sent" Then
If Cells(lRow, 5) <= Date Then
Set xOutlook = CreateObject("Outlook.Application")
Set xMailItem = xOutlook.CreateItem(0)
' For Each rng In Range("C:C")
' If rng.Value Like "*#*" Then
' If xEmailAddr = "" Then
' xEmailAddr = rng.Value
' Else
' xEmailAddr = xEmailAddr & ";" & rng.Value
' End If
' End If
' Next
'Do you really want to have all emails addresses in BCC because thats what you are doing
'I changed the above code to the following lines which will not take the complete column
Set rng = Range("C2:C" & lRow)
xEmailAddr = Join(WorksheetFunction.Transpose(rng), ",")
On Error Resume Next
With xMailItem
.To = ""
.CC = ""
.BCC = xEmailAddr
.Subject = Range("A1").Value
.HTMLBody = strbody
'.Attachments.Add
.Display
End With
MsgBox "E-mail successfully created", 64
Application.DisplayAlerts = False
' I changed that to Email Sent otherwise it will create the mai over and over again
Cells(lRow, 6) = "Email Sent"
Cells(lRow, 7) = "" & Now()
End If
End If
Next
Set OutApp = Nothing
End Sub