How do I send an email to different recipients based on cell value RRS feed

  • Question

  • I am trying to send an email based on email addresses which may include multiple rows without sending out separate emails

    However I do not want to include column A

    Below is the VBA I have so far

    Sub Send_Row_Or_Rows_Attachment_1()
        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 mailAddress As String
        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 Ash = ActiveSheet

         Set FilterRange = Ash.Range("B1:H" & Ash.Rows.Count)
        FieldNum = 1    'Filter column = B because the filter range start in column B

        Set Cws = Worksheets.Add
        FilterRange.Columns(FieldNum).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=Cws.Range("B1"), _
                CriteriaRange:="", Unique:=True

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

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

      mailAddress = ""
                On Error Resume Next
                mailAddress = Application.WorksheetFunction. _
                    VLookup(Cws.Cells(Rnum, 1).Value, _
                              Worksheets("Mailinfo").Range("B1:B" & _
                                    Worksheets("Mailinfo").Rows.Count), 2, False)
                On Error GoTo 0

                If mailAddress <> "" Then

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

    With Ash.AutoFilter.Range
                        On Error Resume Next
                        Set rng = .SpecialCells(xlCellTypeVisible)
                        On Error GoTo 0
                    End With

                    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 = "Your data of " & Ash.Parent.Name _
                                 & " " & Format(Now, "dd-mmm-yy h-mm-ss")

                    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

    Set OutMail = OutApp.CreateItem(0)

                    With NewWB
                        .SaveAs TempFilePath & TempFileName _
                              & FileExtStr, FileFormat:=FileFormatNum
                        On Error Resume Next
                        With OutMail
                            .To = mailAddress
                            .Subject = "VAT"
                            .Attachments.Add NewWB.FullName

    strbody = "Attached is our latest analysis of Concur expense reports which include foreign transactions with VAT present.   Please send the original receipts for the report with foreign transactions and attach a copy of the Expense - Detail page to help identify whose report the receipts belong to.  The original receipts are required in order to reclaim the VAT.  All International expense reports should be sent via intercompany mail, or by a domestic carrier to the address listed below. <br /><br />" & vbNewLine & vbNewLine & _
    "If you have already sent the original receipts for the reports listed in the spreadsheet please disregard this message." & vbNewLine & vbNewLine & _
     "<B><U>Please note this is a separate process from submitting your receipts in Conur</B></U><br /><br />" & vbNewLine & vbNewLine & _
     "Please let me know if you want to change the routing of this report going forward or email \\\\ with any questions.<br /><br />" & _
     "Thank you, <br>" & _
     "Marlene Blum"

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

    Any help you can provide me with this would be greatly appreciated.

    Thank you,

    Marlene Blum

    Saturday, October 6, 2018 3:56 PM

All replies

  • Unfortunately, I can't run your code correctly, and the code is more cumbersome to Write. I wrote a simple example of sending a message based on a cell. Please refer to the following code and update it as your needs:

    Sub SendEmailByOutlook()
            On Error Resume Next
            Dim rowCount, endRowNo
            Dim objOutlook As New Outlook.Application
            Dim objMail   As MailItem
            endRowNo = Cells(1, 1).CurrentRegion.Rows.Count
            Set objOutlook = New Outlook.Application
             'Begin a loop to send an e-mail message, such as starting with the second line, with the first line being the header
            For rowCount = 2 To endRowNo
                    Set objMail = objOutlook.CreateItem(olMailItem)
                    With objMail
                             'Set the recipient address (for example, from the first column of the Excel table in the "e-mail address" field)
                            .To = Cells(rowCount, 1).Value         '""
                             'Set the subject of the message (for example, from the message Subject field in the second column of the Excel Table)
                            .Subject = Cells(rowCount, 2).Value         '"test message"
                             'Set the message content (for example, from the third column of the Excel table in the "mail content" field)
                            .Body = Cells(rowCount, 3).Value         '"message content"
                      End With
                      Set objMail = Nothing
              Set objOutlook = Nothing
    End Sub



    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.

    Monday, October 8, 2018 10:53 AM