VBA Code to send two separate Emails

[tomexcel1]

Hi All,



The below code is currently part of one of my subs, It’s toautomatically send an email when a button is pressed in the worksheet. Myquestion is how can I change this to make it send two separate emails withdifferent bodies and recipients?

Thanks in Advance
Tom

Dim wb1 As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim OutApp As Object
    Dim OutMail As Object

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set wb1 = ActiveWorkbook
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "REJECTED Request -" & " " & Sheet2.Range("D9").Value
    FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
    
    strto = Sheet2.Range("d39") & "@email.co.uk"
    strcc = Sheet11.Range("X6")
    strbcc = "[EMAIL="test@email.co.uk"]test@email.co.uk[/EMAIL]" & ";" & Sheet11.Range("L18")
    strsubject = "HIGHLY SENSITIVE:(REJECTED) Request - " & Sheet2.Range("D9").Value & " - " & Sheet2.Range("G8").Value
    strbody = "Your request has failed." & vbCrLf & "Please see below for further details:"
    wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = strto
        .CC = strcc
        .BCC = strbcc
        .Subject = strsubject
        .Body = strbody
        .Attachments.Add TempFilePath & TempFileName & FileExtStr
        .send
    End With
    On Error GoTo 0
    Kill TempFilePath & TempFileName & FileExtStr
    Set OutMail = Nothing
    Set OutApp = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

 

[Logit]

Re: VBA Code to send two seporate Emails

.

Sub SendEmail()
    Dim OutlookApp As Object
    Dim MItem As Object
    Dim cell As Range
    Dim email_ As String
    Dim cc_ As String
    Dim subject_ As String
    Dim body_ As String


     'Create Outlook object
    Set OutlookApp = CreateObject("Outlook.Application")


     'Loop through the rows
    For Each cell In Columns("a").Cells.SpecialCells(xlCellTypeConstants)


        email_ = cell.Value
        subject_ = cell.Offset(0, 1).Value
        body_ = cell.Offset(0, 2).Value
        cc_ = cell.Offset(0, 3).Value


        'Create Mail Item and send it
        Set MItem = OutlookApp.CreateItem(0)
        With MItem
            .To = email_
            .CC = cc_
            .Subject = subject_
            .Body = body_
                            
            .Display
        End With
    Next
End Sub

	A​	B​	C​	D​	E​
1​	Email Address	Subject	Email Body	Email in CC
2​	test@test.com	Fill your time sheet	Hello, Please make sure you complete time sheet. With regards,	test@testcc.com
3​	test1@test.com	Fill your time sheet	Hello, Please make sure you complete time sheet. With regards,	test1@testcc.com
4​	test2@test.com	Fill your time sheet	Hello, Please make sure you complete time sheet. With regards,	test2@testcc.com
5​
6​	test4@test.com	Fill your time sheet	Hello, Please make sure you complete time sheet. With regards,	test4@testcc.com
7​
8​	test6@test.com	Fill your time sheet	Hello, Please make sure you complete time sheet. With regards,	test6@testcc.com