VBA TO SEND 1 EMAIL BASED ON 3 COLUMNS: FOR "TO", "CC", "BCC"

JuicyMusic

Board Regular
Joined
Jun 13, 2020
Messages
210
Office Version
  1. 365
Platform
  1. Windows
I have 3 macros that i successfully combined sections but still can't get the results I need. The code I have sends an individual email to every email address in column A. The Cc and Bcc works fine, but i need the following for another project at work.

Needed: ONE email to be sent which will show the following on 1 email. Like a company email blast to the employees. Everyone can see who was on the distribution list. Everyone can see who was copied as well,

TO : BASED ON LIST OF EMAIL ADDRESSES IN COLUMN A
CC: BASED ON LIST OF EMAIL ADDRESSES IN COLUMN B
BCC: BASED ON LIST OF EMAIL ADDRESSES IN COLUMN C

1) The number of email addresses in all 3 columns will very depending on whi the user wants to send it to, and too cc on that same email, and to blind copy if there is that need.

2) There will always be an email address in column A, but may not always be any addresses in column B or C if the user doesnt want to copy or blind copy anyone,

3) I have 2 text boxes on the sheet to act as the Subject line and the body of the email. This section of the code i have works well. When i type in the text boxes and run the code the text appears in the subject line and body of the email. Need this still.

4) IMPORTANT: Columns A B and C have a header in row 1 as follows: Send to, CC, BCC. The user may change the header so i dont want the code to be fixed on these names. Email addresses in these 3 columns start on row 2, always.

5) Need this code to be based on "ActiveSheet", not "Sheet1". The user will need to name the sheet however they want. Plus, there will be a 2nd tab for a different kind of emailing specifics which the code i manipulated myself works well for.

6) I need a command button for the user to run the code.

7) Need this code to be set as DISPLAY instead of SEND.

8) The code i have starts off with a "CarryOn" message box to ask the user if they want to run the code. Yes or No.

Thank you in advance,

Juicy
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
The first step would be to post your workbook containing the macro for download. You will need to post it to a CLOUD site like DropBox.com or similar.
 
Upvote 0
The first step would be to post your workbook containing the macro for download. You will need to post it to a CLOUD site like DropBox.com or similar.
Thank you very much. I will respond with the workbook when i get to work on Monday. Ive never posted to a cloud but i will figure it out.

Juicy,
 
Upvote 0
Hi Logit,

I am unable to create a DropBox from work because the company doesn't allow it. I hope the following is acceptable.

1st CODE: - This codes works well and does exactly what I need, but it doesn't allow me to have Row 1 be a header row.
2nd CODE: - I haven't been able to successfully take a portion of this code, that will allow me to use Row1 as the header row, and insert it somewhere in the 1st code.

FYI:
TEXT BOX 1 IS FOR THE TEXT IN THE BODY OF THE EMAIL
TEXT BOX 2 IS FOR TEXT IN THE SUBJECT LINE

HERE IS THE 1ST CODE: Sends an email to the recipient in column A, CC's anyone in column B, and Bcc's anyone in column C. If columns B & C are blank then only the recipient will receive will receive and email. Which is perfect for my needs.

Option Explicit
Sub EMAIL_Distrubtion_OneEmailPerIndividual()

Dim OutApp As Object, OutMail As Object
Dim ws As Worksheet
Dim i As Long, lRow As Long
Set OutApp = CreateObject("Outlook.Application")
'CG changed this line of code from Set ws = ThisWorkbook.Sheets("Sheet1") to ActiveSheet.
Set ws = ActiveSheet
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ws.Range("A" & i).Value
.CC = ws.Range("B" & i).Value
.BCC = ws.Range("C" & i).Value
.Subject = ActiveSheet.TextBoxes(2).Text
.Body = ActiveSheet.TextBoxes(1).Text

'CG changed this line of code from Send to Display to give user a chance to review the email before sending.
.Display
End With
Next i
End With
End Sub


HERE IS THE 2ND CODE: - It has a section that tells the code to start running from Row2. I haven't been able to successfully take a section of it to insert it into the 1st code.

Sub sendEmailMODULE3()
'CCG added this message box but it isn't really necessary if the last line of code says DISPLAY instead of SEND.
arryOn = MsgBox("Do you want to run this macro?", vbYesNo, " Email Distribution List")
If CarryOn = vbNo Then
Exit Sub
End If
' Set up outlook objects for emailing
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'CG deactivated the next comment and 2 lines of code.
' Body text for the email
'Dim strbody As String
'strbody = "This text in the body of your email"
' Strings to contain the email addresses
Dim sendTo As String
sendTo = ""
Dim sendCC As String
sendCC = ""
Dim sendBCC As String
sendBCC = ""
' The cell containing the email address (loop variable)
Dim emailCell As Range
With ActiveSheet
' Cycle through email addresses, from A2 to one before next blank cell in column
For Each emailCell In .Range("A2", .Range("A2").End(xlDown))
' Check each TRUE/FALSE column in same row, add email addresses accordingly
If .Cells(emailCell.Row, "A").Text = "TRUE" Then
sendTo = sendTo & "; " & emailCell.Text
End If
If .Cells(emailCell.Row, "B").Text = "TRUE" Then
sendCC = sendCC & "; " & emailCell.Text
End If
If .Cells(emailCell.Row, "C").Text = "TRUE" Then
sendBCC = sendBCC & "; " & emailCell.Text
End If
Next emailCell
End With
' Generate email in outlook objects defined above
On Error Resume Next
With OutMail
.To = sendTo
.CC = sendCC
.BCC = sendBCC
.Subject = ActiveSheet.TextBoxes(2).Text
'CG changed the next line of code from HTMLBody to just Body.
.Body = ActiveSheet.TextBoxes(1).Text
'CG change this line of code from Display to Send
.Display

End With
On Error GoTo 0
End Sub

I HOPE YOU CAN SEE THE IMAGES I'VE ATTACHED. THANK YOU SO MUCH, JUICY
 

Attachments

  • 1592245944108.png
    1592245944108.png
    3.2 KB · Views: 22
  • MACRO_Email Distribution_Image.PNG
    MACRO_Email Distribution_Image.PNG
    41.5 KB · Views: 24
Upvote 0
.
VBA Code:
Option Explicit

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

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

     'Loop through the rows
    For Each cell In Range("A2:A100").Cells.SpecialCells(xlCellTypeConstants)

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

        'Create Mail Item and send it
        Set MItem = OutlookApp.CreateItem(0)
        With MItem
            .To = email_
            .CC = cc_
            .BCC = bcc_
            .Subject = subject_
            .Body = body_
            .Display
        End With
    Next
End Sub
email.jpg
 
Upvote 0
Logit,
I love it!!!! Can we add a "CarryOn" Message box please?

I added the line of code below but it's giving me a Compile error.

CarryOn = MsgBox("Do you want to run this macro?", vbYesNo, "Email_Distribution List")
If CarryOn = vbNo Then
Exit Sub




Thank you!
Juicy,
 
Upvote 0
.
VBA Code:
Sub SendEmail()
    Dim OutlookApp As Object
    Dim MItem As Object
    Dim cell As Range
    Dim email_ As String
    Dim cc_ As String, bcc_ As String, subject_ As String, body_ As String
     
    Dim answer As Variant
      answer = MsgBox("Do you want to send the email ?", vbYesNo + vbQuestion, "Send Email ?")
      If answer = vbNo Then
          Exit Sub
      End If


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

     'Loop through the rows
    For Each cell In Range("A2:A100").Cells.SpecialCells(xlCellTypeConstants)
 
Upvote 0
.
VBA Code:
Sub SendEmail()
    Dim OutlookApp As Object
    Dim MItem As Object
    Dim cell As Range
    Dim email_ As String
    Dim cc_ As String, bcc_ As String, subject_ As String, body_ As String
    
    Dim answer As Variant
      answer = MsgBox("Do you want to send the email ?", vbYesNo + vbQuestion, "Send Email ?")
      If answer = vbNo Then
          Exit Sub
      End If


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

     'Loop through the rows
    For Each cell In Range("A2:A100").Cells.SpecialCells(xlCellTypeConstants)

Thank you. Perfect.

I am learning more and more. Not just copying the code you provided. I may not always be able to adjust a code to my needs but i get better and better at looking at a code and being able to tell what it does, to a good degree. Im better even with what youve done for me.

SOLVED

MERCI,
JUICY
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,236
Members
448,555
Latest member
RobertJones1986

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