How to insert a dynamic CC email list from Excel column into VBA

A

AmyRenae

New Member
Joined
Apr 22, 2015
Messages
4
I am brand new to VBA and I am trying to automate daily emails by setting up a macro in Excel to send these emails based upon a daily-updated Excel spreadsheet. I was able to utilize Ron de Bruin's website - example 2 from the one titled "mail a row or rows to each person in a range". The macro already loops thru email addresses in column B and creates a separate email with attachment for each unique email address. What I'm trying to do is also include a CC to people listed in column G (which changes everyday). For each email address in column B, there could be several email addresses in column G that I would also want to CC on the email. I've tried so many different things and nothing seems to work. I've copied in the code below and would like to know exactly where I should insert the code for the CC. Looking for some expert help on this. If any additional information is needed, please let me know. Thank you in advance!

Sub MarketManager()

Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Market As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim NewWB As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long


On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

'Set filter sheet, you can also use Sheets("MySheet")
Set Market = ActiveSheet

'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Market.Range("A1:O" & Market.Rows.Count)
FieldNum = 2 'Filter column = B because the filter range start in column A.

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount

'If the unique value is a mail addres create a mail
If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then

'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value





'Copy the visible data in a new workbook
With Market.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With

Set NewWB = Workbooks.Add(xlWBATWorksheet)

rng.Copy
With NewWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With

'Create a file name
TempFilePath = Environ$("temp") & "\"
TempFileName = "Reports" & " " & Format(Now, "dd-mmm-yy")

If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
FileExtStr = ".xlsx": FileFormatNum = 51
End If

'Save, Mail, Close and Delete the file
Set OutMail = OutApp.CreateItem(0)



With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next


With OutMail
.To = Cws.Cells(Rnum, 1).Value
'.cc =
.Subject = "Test"
.Attachments.Add NewWB.FullName
.HTMLBody = "<BODY style=font-size:11pt;font-family:Calibri>Attached please find the updated file.<p>Thanks,<p>Amy</BODY>"
.Display 'Or use Send
End With
On Error GoTo 0
.Close savechanges:=False
End With

Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If

'Close AutoFilter
Market.AutoFilterMode = False

Next Rnum
End If

cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
 
Sort by date Sort by votes
Hello,

bit of a guess, but does this work

Code: 
.To = Cws.Cells(Rnum, 1).Value
.cc = Cws.Cells(Rnum,7).value

Having a copy of the spreadsheet or seeing the data would be a good help.
 
Upvote 0
Thank you for responding onlyadrafter, but that doesn't work. It's one of the ones I previously tried. I don't get an error and the emails are created, but it just leaves the cc blank. The spreadsheet in question is dynamic and changes daily. It tracks missing reports - and can be hundreds of rows. The code in my previous post loops thru the data and creates an email to each unique manager (name in column A, email address in column B). I would like to cc the consultant as well (name in column F, email address in column G). In each email, there's only 1 manager, but there could be multiple consultants who have missing reports and report up thru the manager. All the other columns have data around the missing reports. I'm open to any input...Thank you so much!
 
Upvote 0
Below is a snippet of code using CDO. The Excel VBA part is good for both ways:

Code: 
   ' Mail the Exceptions report - can be mailed even if runAll = False
    If runTest = True Then
        Set sigRef1 = Range("A14")
        Set sigRef2 = Range("A17")
        Set sigRef3 = Range("A20")
        userName = Range("Z100").Value
        passWord = Range("Z101").Value
        If userName = "" Or passWord = "" Then
            MsgBox "Exceptions server email address or password is missing", vbExclamation, "Missing Information"
            GoTo ExitPoint
        End If


        ' Build the style sheets and head text - used for all files
        headText = FormatHead


        ' Build the signature HTML
        sigText = FormatSig(sigRef1.Value, sigRef2.Value, sigRef3.Value)


        If exceptFile = "" Then
            errString = "No exceptions found. " & Now()
            failReturn = ProblemReport(errString, exceptFile, sendDate)
            subjText = "<NO EXCEPTIONS> "
        Else
            subjText = subjText & "Exceptions report for " & sendDate
        End If


[B][COLOR=#ff0000]        Set toRefs = Range("G2:G3")[/COLOR][/B]
[B][COLOR=#ff0000]        Set ccRefs = Range("G7:G12")[/COLOR][/B]
[B][COLOR=#ff0000]        fromList = Range("G20").Value[/COLOR][/B]
        bodyText = "<body>Attached is exceptions file for " & sendDate & ".</body>"
        attachment = exceptFile


        ' Assemble the body
        bodyText = headText & bodyText & sigText


        ' Close the exceptions file so that it can be sent
        If Not exceptFile = vbNullString Then ' FAILS TO IDENTIFY AND CLOSE THE EXCEPTIONS REPORT
            Close #nextFP       ' Close our error log if created
            nextFP = 0


            funcSuccess = SendEmail(toRefs, ccRefs, fromList, subjText, bodyText, attachment, userName, passWord)
            If funcSuccess <> True Then
                On Error GoTo ExitPoint
            End If
        End If
    End If
 
Upvote 0
Thank you for responding Jim... I am using Outlook and did utilize Ron de Bruin's site for the initial code I copied in my first post. I was able to get in the dynamic "To" email addresses, but Ron didn't have an example in how to pull in a dynamic "cc" email address list. And that's where I'm struggling is how to edit the code to be able to pull that in. I've tried several things (including many variations of "Range(G...)), but either end up getting an error or an empty cc line in the email.
I'm open to other suggestions!
 
Upvote 0
I am used to using CDO due to running this from servers, not desktops. I cannot help you with the idiosyncrasies of Outlook, but here is the guts of the CDO mail routine called from the code above. Maybe it will have some clues:
Code: 
Private Function SendEmail(toSrc As Range, _
    ccSrc As Range, _
    fromList As String, _
    subjText As String, _
    bodyText As String, _
    attachment As String, _
    userName As String, _
    passWord As String) As Boolean




    Dim toList As String
    Dim ccList As String
    Dim config As Object
    Dim msgStruct As Object
    Dim addressee As Variant
    Dim cellRef As Range
    Const cdoBasic = 1


    '  Build recipient list
    For Each cellRef In toSrc
        If Len(toList) > 1 Then
            toList = toList & ";" & cellRef.Value
        Else
            toList = toList & cellRef.Value
        End If
    Next cellRef


    '  Build recipient list
    For Each cellRef In ccSrc
        If Len(cellRef) > 1 Then
            ccList = ccList & ";" & cellRef.Value
        Else
            ccList = ccList & cellRef.Value
        End If
    Next cellRef


    Set msgStruct = CreateObject("CDO.Message")
    Set config = CreateObject("CDO.Configuration")


    With config
        .Fields(cdoSendUsingMethod) = cdoSendUsingPort
        .Fields(cdoSMTPServer) = "smtp.mybullseyeonline.com"
        .Fields(cdoSMTPServerPort) = 5125
        .Fields(cdoSMTPAuthenticate) = cdoBasic
        .Fields(cdoSendUserName) = userName
        .Fields(CdoSendPassword) = passWord
        .Fields.Update
    End With


    With msgStruct
        Set .Configuration = config
        .From = fromList
        .To = toList
        If Len(ccList) > 0 Then
            .Cc = ccList
        End If
        .Subject = subjText
        .HTMLBody = bodyText
        .AddAttachment attachment
        .Send
    End With
    
    Set config = Nothing
    Set msgStruct = Nothing
    SendEmail = True
End Function    ' SendMail
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
VBA to save file to SharePoint and attach to outlook template saved in SharePoint
Replies
6
Views
560
Chris8630
C
M
  • Question Question
Email file VBA - change attachment from excel to PDF?
Replies
2
Views
423
MOB
M
B
  • Question Question
VBA copy Values exclude 1 column and formula
Replies
6
Views
426
Anthony47
A
H
  • Question Question
Macro to email Report
Replies
2
Views
668
howard
H
M
  • Question Question
Creating and emailing Excel sheet with only visible data
Replies
0
Views
572
mecerrato
M

Share this page

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