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

AmyRenae · Apr 22, 2015

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

onlyadrafter · Apr 25, 2015

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.

AmyRenae · Apr 28, 2015

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!

JimSnyder · Apr 28, 2015

Are you using Outlook or CDO?
EDIT: Ron de Bruin has a good website to help:
Mail from Excel with Outlook (VBA)

Although not complete, it is likely the best source on the web.

JimSnyder · Apr 28, 2015

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

AmyRenae · Apr 28, 2015

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!

JimSnyder · Apr 28, 2015

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

AmyRenae · Apr 28, 2015

Thank you Jim! I will take a look after my meetings today and see if I can extract what I need...

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

AmyRenae

New Member

Excel Facts

onlyadrafter

Well-known Member

AmyRenae

New Member

JimSnyder

Board Regular

JimSnyder

Board Regular

AmyRenae

New Member

JimSnyder

Board Regular

AmyRenae

New Member

Similar threads

Forum statistics

Share this page

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

New Member

Excel Facts

Well-known Member

New Member

Board Regular

Board Regular

New Member

Board Regular

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock