CODEWITHSUNDEEP
excelvbaoutlook
ScottMc
ScottMc

Reputation: 1

Send email to recipients with (varying) multiple attachments based on criteria in columns

I am currently trying to write a macro where it will email multiple attachments to recipients depending on whether each column has an X next to their name. I have the email addresses in column G and 11 different report names ranging from columns H:R.

So far I've written a macro that will send an attachment (Report 1) if email recipients have an X in column H, but I'm unsure how to write a macro so it will search columns H:R for X and send the corresponding reports (i.e. If an email recipient has an X in column H and column J then I want them to receive both Report 1 and Report 3 in the same email).

Sorry if my explanation is difficult to interpret.
Any help is much appreciated

Private Sub CommandButton1_Click()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range


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

    Set sh = Sheets("Contacts")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("G").Cells.SpecialCells(xlCellTypeConstants)

        If cell.Value Like "?*@?*.?*" And _
            LCase(Cells(cell.Row, "H").Value) = "x" Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .to = cell.Value
                .Subject = "Report 1"
                .body = "Hi " & cell.Offset(0, -3).Value
            'Link file path for attachment
                .Attachments.Add ("C:\Users\smcelroy021218\Desktop\Email Macro Working.xlsm")
                .Display
            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Upvotes: 0

Views: 933

Answers (1)

Tim Williams
Tim Williams

Reputation: 166196

You don't say where the file paths come from: in this example I'm picking them up from the first row of your sheet (so from H1:R1).

Private Sub CommandButton1_Click()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range, c As Range
    Dim FileCell As Range
    Dim rng As Range, rngAttach As Range

    Set sh = Sheets("Contacts")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("G").Cells.SpecialCells(xlCellTypeConstants)

        Set rngAttach = cell.Offset(0, 7).Resize(1, 11)

        'EDIT: must have at least one attachment to create a mail
        If cell.Value Like "?*@?*.?*" And _
                          Application.Countif(rngAttach, "x") > 0 Then

            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .to = cell.Value
                .Subject = "Report 1"
                .body = "Hi " & cell.Offset(0, -3).Value

                'loop over H:R and check for "x"
                For Each c In rngAttach.Cells
                    If LCase(Trim(c.Value)) = "x" Then
                        'pick up the file path from the top row of the sheet
                        .Attachments.Add sh.Cells(1, c.Column).Value
                    End If
                Next c

                .Display
            End With

            Set OutMail = Nothing

        End If
    Next cell

    Set OutApp = Nothing

End Sub

Upvotes: 1

Related Questions