VBA Code to send two separate Emails

tomexcel1

New Member
Joined
Feb 22, 2018
Messages
47
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

Code:
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
 

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
Re: VBA Code to send two seporate Emails

.
Code:
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




[Table="width:, class:head"][tr=bgcolor:#888888][th] [/th][th]
A
[/th][th]
B
[/th][th]
C
[/th][th]
D
[/th][th]
E
[/th][/tr]
[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
1
[/td][td]Email Address[/td][td]Subject[/td][td]Email Body[/td][td]Email in CC[/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
2
[/td][td]test@test.com[/td][td]Fill your time sheet[/td][td]Hello,


Please make sure you complete time sheet.


With regards,[/td][td]test@testcc.com[/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
3
[/td][td]test1@test.com[/td][td]Fill your time sheet[/td][td]Hello,


Please make sure you complete time sheet.


With regards,[/td][td]test1@testcc.com[/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
4
[/td][td]test2@test.com[/td][td]Fill your time sheet[/td][td]Hello,


Please make sure you complete time sheet.


With regards,[/td][td]test2@testcc.com[/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
5
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
6
[/td][td]test4@test.com[/td][td]Fill your time sheet[/td][td]Hello,


Please make sure you complete time sheet.


With regards,[/td][td]test4@testcc.com[/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
7
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#888888]
8
[/td][td]test6@test.com[/td][td]Fill your time sheet[/td][td]Hello,


Please make sure you complete time sheet.


With regards,[/td][td]test6@testcc.com[/td][td][/td][/tr]
[/table]
 
Upvote 0

Forum statistics

Threads
1,223,903
Messages
6,175,284
Members
452,630
Latest member
OdubiYouth

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top