(Solved) – Macro to send emails all people by looking for unique values in a column(Generated after Running another Macro)


I have two macros.
Macro 1 :
When I upload a file and Run Macro 1, I get 2 new sheets (Sheet 1 and Sheet 2) giving me the result.

Macro 2:
I have a TABLE with list of people and their names and a condition(Y/N) column.
Column 1(Name) Column 2(Email) Column 3 (Condition Y/N)
I want to send out emails to all people in the TABLE whose name matches with the unique values(name) in one of the columns in the Sheet 1 generated after running Macro 1.
So I want something that looks up the column in Sheet 1 and may be changes the Condition to Y in the TABLE for all unique names found in that Column in Sheet 1.(I can FILTER my TABLE in POWER QUERY to show only the rows with Condition “Y”.
Also when the SINGLE Outlook pops up with the all people in the “To” , I also want Sheet 1 or Sheet 2 to be attached to the Outlook.

Option Explicit

Public Sub SendEmail()
    ' For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    ' Working in Office 2000-2016
    ' Adapted by Ricardo Diaz ricardodiaz.co

    Dim OutApp As Object
    Dim OutMail As Object
    Dim sourceTable As ListObject
    Dim evalRow As ListRow

    Dim counter As Long
    Dim toArray() As Variant

    Application.ScreenUpdating = False

    Set OutApp = CreateObject("Outlook.Application")

    Set sourceTable = Range("Table6").ListObject ' -> Set the table's name

    On Error GoTo cleanup

    ' Loop through each table's rows
    For Each evalRow In sourceTable.ListRows

        If evalRow.Range.Cells(, 2).Value Like "?*@?*.?*" And LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
            ReDim Preserve toArray(counter)
            toArray(counter) = evalRow.Range.Cells(, 2).Value
            counter = counter   1
        End If

    Next evalRow

    ' Setup the email
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next

    With OutMail
        ' Add gathered recipients
        For counter = 0 To UBound(toArray)
            .Recipients.Add (toArray(counter))
        Next counter

        .Subject = "Reminder"

        .Body = "Dear All" _
                & vbNewLine & vbNewLine & _
                "Please comply with the transfers in the attached file. " & _
                "Look up for your store and process asap."

        'You can add files also like this
        '.Attachments.Add ("C:test.txt") ' -> Adjust this path

        .Display     ' -> Or use Display
    End With

    On Error GoTo 0
    Set OutMail = Nothing

    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Code to Attach sheet 1 (doesn’t work)

    file_name_import = Format(Now, "yyyy-mm-dd hh-mm-ss")
    file_name_import = file_name_import & " - File 1.xlsx"

    Worksheets("Sheet 1").Copy
    ChDir "H:Folder 1Folder 2Folder 3Folder 4"
    ActiveWorkbook.SaveAs Filename:= _
    "H:Folder 1Folder 2Folder 3Folder 4File 1" & file_name_import, _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

.Attachments.Add "H:Folder 1Folder 2Folder 3Folder 4File 1" & file_name_import

So basically I want to add the above Code into the Code for Macro 2 so that when I run the Macro 2 my Outlook Pops up with all required people in “To” and with the attachment.

Thanks for the help!

Leave a Reply

Your email address will not be published. Required fields are marked *