I'm trying to create the code below to send emails to multiple recipients listed in a worksheet column and CC recipients in another column. I don't get an error, but it is not displaying nor sending the email. I'm missing something somewhere.
Code
Sub EmailReminder()
Dim oOL As Outlook.Application, oMail As Outlook.MailItem, oNS As Outlook.Namespace
Dim oMapi As Outlook.MAPIFolder, oExpl As Outlook.Explorer
Dim sBody As String, sRecip As String, sSubj As String, dDate As String, bSend As Boolean
Dim oWS As Worksheet, r As Long, i As Long, sStart As String
If MsgBox("Send directly(Y) or display(N)?", vbYesNo) = vbYes Then bSend = True
On Error Resume Next
Set oWS = Sheet1
Set oOL = New Outlook.Application
Set oExpl = oOL.ActiveExplorer
If TypeName(oExpl) = "Nothing" Then
Set oNS = oOL.GetNamespace("MAPI")
Set oMapi = oNS.GetDefaultFolder(olFolderInbox)
Set oExpl = oMapi.GetExplorer
End If
With oWS.Range("Z3").End(xlDown)
r = .CurrentRegion.Rows.Count
For i = 3 To r
dDate = .Cells(i, 30)
If dDate = True Then
sRecip = Join(Application.Transpose(Worksheets("Sheet1").Range("AA:AA").Value), ";")
sSubj = "Please Review"
sBody = "RESPONSE REQUIRED." & vbNewLine & vbNewLine & _
If bSend = False Then
Set oMail = oOL.CreateItem(olMailItem)
With oMail
.Subject = sSubj
.Date = sDate
.Body = sBody
.Recipients.Add sRecip
.Display 'NOT.Send
End With
End If
End If
Next i
End With
End Sub
Display More