How to send one email to a recipient listed multiple times using vba?

[Hlbet21]

I currently have a macro that sends out emails automatically based on the parameters I have set in my code. My spreadsheet contains multiple recipients. Often times a recipient may be listed more than once. Currently, my macros runs line by line where each row that meets my parameters gets an email to the linked recipient. If I have one recipient who is listed multiple times, this person will get more than one email. Before I automated this process, emails were sent out manually. If a recipient was listed more than once each row was combined into a table so they would only get one email. Is it possible for my recipients who are listed more than once to get Only one email rather than multiple using vba?

 

[Logit]

.
The following macro will check the main sheet for identical email address on multiple rows. Copy those rows to a temporary sheet, then copy that sheet as an attachment
to the email sent to that email address.

It then repeats the process until all email addresses/rows have been processed.

Option Explicit
Sub sintek()
Dim Data, Dict As Object, Path As String, File As String, i As Long
Set Dict = CreateObject("Scripting.Dictionary")
Path = ThisWorkbook.Path: Sheets.Add.Name = "Temp"
With Sheets("Sheet1").ListObjects(1).Range
    Data = .Value
    For i = 2 To UBound(Data, 1)
        If Not Dict.exists(Data(i, 4)) Then
            File = Path & "\" & Data(i, 4)
            Dict.Add Data(i, 4), 1
            .AutoFilter 4, Data(i, 4)
            .SpecialCells(12).Copy Sheets("Temp").Range("A1")
            .AutoFilter
            With Sheets("Temp")
                .Columns.AutoFit
                .Copy
                ActiveWorkbook.SaveAs File & ".xlsx", 51
                ActiveWorkbook.Close saveChanges:=False
                .UsedRange.Delete
            End With
            With CreateObject("Outlook.Application").CreateItem(0)
                .Display
                .To = Data(i, 12)
                .Subject = "Whatever"
                .Body = "Whatever you want to say"
                .Attachments.Add File & ".xlsx"
                '.Send
                .Display
                Kill File & ".xlsx"
            End With
        End If
    Next i
End With
Application.DisplayAlerts = False: Sheets("Temp").Delete: Application.DisplayAlerts = True
End Sub

Download example workbook : WORKS - Filter Data n Email MultiAddresses.xlsm

 

[Hlbet21]

Thank you! I am trying to run the code provided above and it keeps erroring (subscript out of range) at line With Sheets(“Sheet1”).ListObjects(1).Range. Any suggestions?

 

[Hlbet21]

.
The following macro will check the main sheet for identical email address on multiple rows. Copy those rows to a temporary sheet, then copy that sheet as an attachment
to the email sent to that email address.

It then repeats the process until all email addresses/rows have been processed.

Option Explicit
Sub sintek()
Dim Data, Dict As Object, Path As String, File As String, i As Long
Set Dict = CreateObject("Scripting.Dictionary")
Path = ThisWorkbook.Path: Sheets.Add.Name = "Temp"
With Sheets("Sheet1").ListObjects(1).Range
    Data = .Value
    For i = 2 To UBound(Data, 1)
        If Not Dict.exists(Data(i, 4)) Then
            File = Path & "\" & Data(i, 4)
            Dict.Add Data(i, 4), 1
            .AutoFilter 4, Data(i, 4)
            .SpecialCells(12).Copy Sheets("Temp").Range("A1")
            .AutoFilter
            With Sheets("Temp")
                .Columns.AutoFit
                .Copy
                ActiveWorkbook.SaveAs File & ".xlsx", 51
                ActiveWorkbook.Close saveChanges:=False
                .UsedRange.Delete
            End With
            With CreateObject("Outlook.Application").CreateItem(0)
                .Display
                .To = Data(i, 12)
                .Subject = "Whatever"
                .Body = "Whatever you want to say"
                .Attachments.Add File & ".xlsx"
                '.Send
                .Display
                Kill File & ".xlsx"
            End With
        End If
    Next i
End With
Application.DisplayAlerts = False: Sheets("Temp").Delete: Application.DisplayAlerts = True
End Sub

Download example workbook : WORKS - Filter Data n Email MultiAddresses.xlsm

Thank you! I am trying to run the code provided above and it keeps erroring (subscript out of range) at line With Sheets(“Sheet1”).ListObjects(1).Range. Any suggestions?

 

[Logit]

Sheet1 is the name of the sheet holding all the data. Either change your sheet name to Sheet1 or change the code to reference
your actual sheet name.

 

[Hlbet21]

Sheet1 is the name of the sheet holding all the data. Either change your sheet name to Sheet1 or change the code to reference
your actual sheet name.

I did both of those and it’s still running an error.

 

[Hlbet21]

.
The following macro will check the main sheet for identical email address on multiple rows. Copy those rows to a temporary sheet, then copy that sheet as an attachment
to the email sent to that email address.

It then repeats the process until all email addresses/rows have been processed.

Option Explicit
Sub sintek()
Dim Data, Dict As Object, Path As String, File As String, i As Long
Set Dict = CreateObject("Scripting.Dictionary")
Path = ThisWorkbook.Path: Sheets.Add.Name = "Temp"
With Sheets("Sheet1").ListObjects(1).Range
    Data = .Value
    For i = 2 To UBound(Data, 1)
        If Not Dict.exists(Data(i, 4)) Then
            File = Path & "\" & Data(i, 4)
            Dict.Add Data(i, 4), 1
            .AutoFilter 4, Data(i, 4)
            .SpecialCells(12).Copy Sheets("Temp").Range("A1")
            .AutoFilter
            With Sheets("Temp")
                .Columns.AutoFit
                .Copy
                ActiveWorkbook.SaveAs File & ".xlsx", 51
                ActiveWorkbook.Close saveChanges:=False
                .UsedRange.Delete
            End With
            With CreateObject("Outlook.Application").CreateItem(0)
                .Display
                .To = Data(i, 12)
                .Subject = "Whatever"
                .Body = "Whatever you want to say"
                .Attachments.Add File & ".xlsx"
                '.Send
                .Display
                Kill File & ".xlsx"
            End With
        End If
    Next i
End With
Application.DisplayAlerts = False: Sheets("Temp").Delete: Application.DisplayAlerts = True
End Sub

Download example workbook : WORKS - Filter Data n Email MultiAddresses.xlsm

I have set of parameters ( if then statements - to exclude certain rows) that I need to add to this code before it makes/saves the attachment. Where would be the best place to set them in the code? I’m absolutely stuck on this.