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

Hlbet21

New Member
Joined
Dec 31, 2020
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
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?
 

Some videos you may like

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
3,973
.
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.

VBA Code:
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
 
Solution

Hlbet21

New Member
Joined
Dec 31, 2020
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
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

New Member
Joined
Dec 31, 2020
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
.
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.

VBA Code:
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

Well-known Member
Joined
Aug 31, 2016
Messages
3,973

ADVERTISEMENT

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

New Member
Joined
Dec 31, 2020
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
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

New Member
Joined
Dec 31, 2020
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
.
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.

VBA Code:
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,127,853
Messages
5,627,263
Members
416,236
Latest member
Lynchbox

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top