Using VBA to send emails via outlook using excel cells

[craneg]

Hi all,

I've been trying to create a macro that will allow me to send emails from Outlook 2010 using details from an excel 2010 spreadsheet. I have a list of email addresses in Column F, a list of reports in Column N and an IF function in Column D. What I'm trying to achieve is that when a report is due, the IF function in Column D shows the message "Send Reminder". I can then click the macro button and for all cells in Column D that shows "Send Reminder", Outlook will send an email to the corresponding email address in that row with the corresponding report title in that row. The code I have compiled so far is close, but as long as one cell in Column D shows "Send Reminder" it will send one email to every email address in Column F and with only the latest report. I have posted the code below and I would be extremely grateful if someone could give me some pointers. Thanks!





Private Sub CommandButton1_Click()


Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As Range, cl As Range
Dim sTo As String

Set MailDest = Worksheets("AUAL").Range("F9:F181")


For Each cl In MailDest
sTo = sTo & ";" & cl.Value
Next


sTo = Mid(sTo, 2)

Set OutLookApp = CreateObject("OutLook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)


With OutLookMailItem
For iCounter = 9 To WorksheetFunction.CountA(Columns(6))
If Cells(iCounter, 6).Offset(0, -2) = "Send Reminder" Then
MailDest = Cells(iCounter, 6).Value




End If


Next iCounter


For iCounter = 9 To WorksheetFunction.CountA(Columns(14))
If Cells(iCounter, 14).Offset(0, -10) = "Send Reminder" Then
Report = Cells(iCounter, 14).Value
ElseIf Report <> "" And Cells(iCounter, 14).Offset(0, -10) = "Send Reminder" Then
Report = Report & ";" & Cells(iCounter, 14).Value


End If
Next




.To = sTo
.Subject = "Corporate Calendar Reminder"
.Body = "Please note that you have an upcoming report" & " '" & Report & "'. " & "in the next fortnight. Please ensure that this report is sent and provide a copy for Compliance"
.Display
End With


Set OutLookMailItem = Nothing
Set OutLookApp = Nothing

[mancubus]

welcome to vbax craneg.

registering means you have read the forum rules. :devil
and as per forum rules, members should use code tags when posting code: http://www.vbaexpress.com/forum/faq....ntrib_faq_item

that said, try below. i am not sure if it Works or not, because your requirement seems unclear to me.

Sub vbax_54983_Send_Email_BasedOn_Condition()
    Dim olApp As Object, olMail As Object
    Dim i As Long
    
    Set olApp = CreateObject("Outlook.Application")
    
    Worksheets("AUAL").Activate
    
    For i = 9 To Cells(Rows.Count, 6).End(xlUp).Row
        If Cells(i, 4).Value = "Send Reminder" Then
            Set olMail = olApp.CreateItem(olMailItem)
            With olMail
                .To = Cells(i, 6)
                .Subject = "Corporate Calendar Reminder"
                .Body = "Please note that you have an upcoming report '" & Cells(i, 14) & "' in the next fortnight. " & _
                    "Please ensure that this report is sent and provide a copy for Compliance."
                .Display
                '.Save
                '.Send
            End With
        End If
    Next
End Sub