vba RRS feed

  • Question

  • Situation: I send out mass emails to lots of people individually with related line items as attachment via vba code through outlook.  The codes are from Ron’s website as attached below. I have three more questions need assistance on:

    Any assistance will be very much appreciated!!

    1. CC recipients list in outlook mail

          .CC= Range (“A2”) and

           If range(“a2”).value <> range(“b2”).value

    Then .CC= range(“B2”).value as well

    1. Automatically update the template

    a)      after I executed the code to send out mass emails, is there a way which the template can automatically update the email has been send, and the value = range(“A2”) which is the email address I used in the email

    b)       after I executed the code to send out mass emails, is there any way which template can automatically record the email has been send on formate (now, “dd-mmm-yyyy”)

    Codes from Ron’s website:

    Sub Sendemails_2()
    'Working in 2000-2016
     Dim Outapp As Object
        Dim OutMail As Object
        Dim rng As Range
        Dim Ash 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
        Dim Strbody As String

        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 Ash = Sheets("Mysheet")
        'Set filter range and filter column (column with e-mail addresses)
        Set FilterRange = Ash.Range("A1:Z" & Ash.Rows.Count)
        FieldNum = 3 '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 Ash.AutoFilter.Range
                        On Error Resume Next
                        Set rng = .SpecialCells(xlCellTypeVisible)
                        On Error GoTo 0
                    End With
                    Set NewWB = Workbooks.Add(xlWBATWorksheet)
                    With NewWB.Sheets(1)
                        .Cells(1).PasteSpecial Paste:=8
                        .Cells(1).PasteSpecial Paste:=xlPasteValues
                        .Cells(1).PasteSpecial Paste:=xlPasteFormats
                        Application.CutCopyMode = False
                    End With
                    'Create a file name
                    TempFilePath = Environ$("temp") & "\"
                    TempFileName = Ash.Parent.Name _
                                 & " " & Format(Now, "dd-mmm-yy")
                    If Val(Application.Version) < 12 Then
                        'You use Excel 97-2003
                        FileExtStr = ".xls": FileFormatNum = -4143
                        'You use Excel 2007-2016
                        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 = Range("A2").Value
                            .Subject = "Nee Assistance " & Range("F2").Value & Format(Now, "dd-mmm-yyyy")
                            .Attachments.Add NewWB.FullName
                            .Attachments.Add " "
                            .HTMLBody = Strbody
                            .Importance = 2
                            .Sensitivity = 3
                            .ReadReceiptRequested = True
                            Application.Wait (Now + TimeValue("0:00:02"))
                            Application.SendKeys "%s"

     '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
                Ash.AutoFilterMode = False
            Next Rnum
        End If
        Set Outapp = Nothing
        Application.DisplayAlerts = False
        Application.DisplayAlerts = True
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    End Sub

    Friday, November 25, 2016 9:57 AM

All replies

  • Hi,

    I notice your issue is code related. And our forum focuses on general discussion for Excel application. To better resolve your issue, I will help to move this thread to Excel for Developers forum for more help.

    Thanks for your understanding :)


    Winnie Liang

    Please remember to mark the replies as answers if they help.
    If you have feedback for TechNet Subscriber Support, contact

    Monday, November 28, 2016 2:25 AM
  • Hi,

    >>CC recipients list in outlook mail

    You could pass a variable to the .CC. Use something like:


    Dim ccMail As String

    ccMail = Range("A2").Value

    If Range("A2").Value <> Range("B2").Value Then

    ccMail = ccMail & ";" & Range("B2").Value

    End If


     .CC = ccMail


    From the code, I think it is creating the mails but doesn’t send them. I think you are sending manually by clicking Send button. You could add Line .Send  after .display to send the mail. Then it is simple to record the sent time.

    Could you explain more about "Automatically update the template"?



    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact

    Tuesday, November 29, 2016 8:05 AM