简体   繁体   中英

Excel VBA - Send outlook email


In Cell AI have names, eg John Smith
In Cell BI have a criteria - Due/ Not Due.
I need to somehow modify the below code to do the following:
Generate emails from cell A, in the format john.smith@company.com and Then send out a reminder email, but only to unique emails in one email. So far this is what I have:

Sub SendEmail()

    Dim OutlookApp As Outlook.Application
    Dim MItem As Outlook.MailItem
    Dim cell As Range
    Dim Subj As String
    Dim EmailAddr As String
    Dim Recipient As String
    Dim Msg As String

    'Create Outlook object
    Set OutlookApp = New Outlook.Application

    'Loop through the rows
    For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeVisible)
        If cell.Value Like "*@*" And _
           LCase(Cells(cell.Row, "B").Value) = "Due" _
            Then
            EmailAddr = EmailAddr & ";" & cell.Value
        End If
    Next

    Msg = "Please review the following message."
    Subj = "This is the Subject Field"

    'Create Mail Item and view before sending
    Set MItem = OutlookApp.CreateItem(olMailItem)
    With MItem
        .To = EmailAddr
        .Subject = Subj
        .Body = Msg
        .Display
    End With

End Sub

I can't get much further, unfortunately. Can anyone help me please?

LCase(Cells(cell.Row, "B").Value) = "Due"

This will always return false, because LCase() converts the whole string to L ower case and you're comparing it to "Due" which has an upper case "D"

Either, change your comparison string to "due" :

LCase(Cells(cell.Row, "B").Value) = "due"

Or (not recommended, but showing for education purpose) change your string operation to proper case:

StrConv(Cells(cell.Row, "B").Value, vbProperCase) = "Due"

Fully scoped answer here. I put comments in the areas of the existing code that I added / edited.

Sub SendEmail()

    Dim OutlookApp As Outlook.Application
    Dim MItem As Outlook.MailItem
    Dim cell As Range
    Dim Subj As String
    Dim EmailAddr As String
    Dim Recipient As String
    Dim Msg As String

    'Create Outlook object
    Set OutlookApp = New Outlook.Application

    'Loop through the rows
    For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeVisible)
        If cell.Value Like "*@*" And _
           LCase(Cells(cell.Row, "B").Value) = "due" Then
            'first build email address
            EmailAddr = LCase$(Replace(cell.Value, " ", ".")) & "@company.com"
            'then check if it is in Recipient List build, if not, add it, otherwise ignore
            If InStr(1, Recipient, EmailAddr) = 0 Then Recipient = Recipient & ";" & EmailAddr
        End If
    Next

    Recipient = Mid(Recipient, 2) 'get rid of leaing ";"

    Msg = "Please review the following message."
    Subj = "This is the Subject Field"

    'Create Mail Item and view before sending
    Set MItem = OutlookApp.CreateItem(olMailItem)
    With MItem
        .To = Recipient 'full recipient list
        .Subject = Subj
        .Body = Msg
        .Display
    End With

End Sub

Maybe like this?

Sub SendEmail()

Dim OutlookApp As Outlook.Application
Dim MItem As Outlook.MailItem
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim Recipient As String
Dim Msg As String

'Create Outlook object
Set OutlookApp = New Outlook.Application

'Loop through the rows
For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeVisible)
    If cell.Value Like "*@*" And _
       LCase(Cells(cell.Row, "B").Value) = "due" _
        Then
        EmailAddr = cell.Value
    End If


    Msg = "Please review the following message."
    Subj = "This is the Subject Field"

    'Create Mail Item and view before sending
    Set MItem = OutlookApp.CreateItem(olMailItem)
    With MItem
        .To = EmailAddr
        .Subject = Subj
        .Body = Msg
        .Display
    End With

    EmailAddr = ""

Next

End Sub

What I did was: Include the creation of the mailitem into the loop, and reset the variable EmailAddr after the mail is displayed

Also, I updated the code with Macro Man his suggestion.

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM