vba, Email multiple addresses with multiple rows ( Send multiples rows to a single email)

A

ad aden

New Member
Joined
Oct 2, 2022
Messages
7
Office Version
  1. 365
Platform
  1. Windows
Hello,
I'm looking for a solution with my Excel VBA problem.
Hopefully someone is able to help.

Im looking for a solution, to send multiples row to a same email address and the body of the email have to be all the information of each row
IDSubjectStatusWHLast Inbound DateActual DateDWREmail
15468​
caso 1PendingA1datedatedateA1@hotmail.com
6546​
caso 2PendingA6datedatedateA6@hotmail.com
5648​
caso 3PendingA6datedatedateA6@hotmail.com
45868​
caso 4PendingB1datedatedateB1@hotmail.com
40958​
caso 5PendingB6datedatedateB6@hotmail.com
54865​
caso 6PendingA1datedatedateA1@hotmail.com
45456​
caso 7PendingC1datedatedateC1@hotmail.com
215623​
caso 8PendingA6datedatedateA6@hotmail.com
56462​
caso 9PendingB6datedatedateB6@hotmail.com
86109​
caso 10PendingB6datedatedateB6@hotmail.com
35215​
caso 11PendingD1datedatedateD1@hotmail.com
65485​
caso 12PendingE1datedatedateE1@hotmail.com

In this case, each email addres match with the column WH
So Each email have to receive the information of all the row that apply on them.

Is someone able to help me with the code for this?
I've been searching, but I were not able to find the right coding.

Thanks in advance.

Kind regards, Ad.
 

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
Sort by date Sort by votes
Hi Ad,
see the code below, adapted from a previous post of mine. Remember to adapt the sheet name and custom parts in the code.

VBA Code: 
Sub mailad_aden()
    'https://www.mrexcel.com/board/threads/vba-email-multiple-addresses-with-multiple-rows-send-multiples-rows-to-a-single-email.1218125/
    
    Dim Wks    As Worksheet
    Dim OutMail As Object, OutApp As Object
    Dim myRng  As Range
    Dim MyList   As Object
    Dim MyWh   As Variant
    Dim LastRow As Long
    Dim uniquesArray()
    Dim Dest   As String, strBody As String
    
    Set MyList = CreateObject("System.Collections.ArrayList")
    Set Wks = ThisWorkbook.Sheets("Sheet1")        '==> 'Adapt sheet name as needed
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    With Wks
        For Each MyWh In .Range("D2", .Range("D" & .Rows.Count).End(xlUp))
            If Not MyList.Contains(MyWh.Value) Then MyList.Add MyWh.Value
        Next
    End With
    
    For Each MyWh In MyList
        
        Wks.Range("A1:H" & Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=4, Criteria1:=MyWh
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        
        LastRow = Cells(Rows.Count, "A").End(xlUp).Row
        
        Set myRng = Wks.Range("A1:H" & LastRow).SpecialCells(xlCellTypeVisible)
        
        Dest = Cells(LastRow, "H").Value
        strBody = "Hi everyone," & "<br>" & "here's my message" & "<br/><br>" '==> to adapt
        
        With OutMail
            .To = Dest
            .CC = ""
            .BCC = ""
            .Subject = "Email Subject"        '==> to adapt
            .HTMLBody = strBody & RangetoHTML(myRng)
            .Display
            '.Send
        End With
        On Error GoTo 0
    Next
    
    On Error Resume Next
    Wks.ShowAllData
    On Error GoTo 0
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
End Sub
Function RangetoHTML(myRng As Range)
    
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim fso    As Object
    Dim ts     As Object
    Dim i      As Integer
    Dim LastRow2 As Long
    
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    myRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
        
        LastRow2 = .Cells(Rows.Count, "A").End(xlUp).Row + 1
        
        For i = 7 To 12
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i
    End With
    
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).Range("A1:" & "G" & LastRow2).Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                  "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

After testing you can edit this line for automatic message sending

Code: 
'.Display
.Send
 
Upvote 0
Sequoyah said:
Hi Ad,
see the code below, adapted from a previous post of mine. Remember to adapt the sheet name and custom parts in the code.

VBA Code: 
Sub mailad_aden()
    'https://www.mrexcel.com/board/threads/vba-email-multiple-addresses-with-multiple-rows-send-multiples-rows-to-a-single-email.1218125/
   
    Dim Wks    As Worksheet
    Dim OutMail As Object, OutApp As Object
    Dim myRng  As Range
    Dim MyList   As Object
    Dim MyWh   As Variant
    Dim LastRow As Long
    Dim uniquesArray()
    Dim Dest   As String, strBody As String
   
    Set MyList = CreateObject("System.Collections.ArrayList")
    Set Wks = ThisWorkbook.Sheets("Sheet1")        '==> 'Adapt sheet name as needed
   
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
   
    With Wks
        For Each MyWh In .Range("D2", .Range("D" & .Rows.Count).End(xlUp))
            If Not MyList.Contains(MyWh.Value) Then MyList.Add MyWh.Value
        Next
    End With
   
    For Each MyWh In MyList
       
        Wks.Range("A1:H" & Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=4, Criteria1:=MyWh
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
       
        LastRow = Cells(Rows.Count, "A").End(xlUp).Row
       
        Set myRng = Wks.Range("A1:H" & LastRow).SpecialCells(xlCellTypeVisible)
       
        Dest = Cells(LastRow, "H").Value
        strBody = "Hi everyone," & "<br>" & "here's my message" & "<br/><br>" '==> to adapt
       
        With OutMail
            .To = Dest
            .CC = ""
            .BCC = ""
            .Subject = "Email Subject"        '==> to adapt
            .HTMLBody = strBody & RangetoHTML(myRng)
            .Display
            '.Send
        End With
        On Error GoTo 0
    Next
   
    On Error Resume Next
    Wks.ShowAllData
    On Error GoTo 0
   
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
   
End Sub
Function RangetoHTML(myRng As Range)
   
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim fso    As Object
    Dim ts     As Object
    Dim i      As Integer
    Dim LastRow2 As Long
   
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    myRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
       
        LastRow2 = .Cells(Rows.Count, "A").End(xlUp).Row + 1
       
        For i = 7 To 12
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i
    End With
   
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).Range("A1:" & "G" & LastRow2).Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                  "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

After testing you can edit this line for automatic message sending

Code: 
'.Display
.Send
Click to expand...
Hello Sequoyah,

Thanks for taking the time to give me this information, for some reason when i run the macro, just the first display got an email in To: the rest of the display got the information together as i want, but no email in To.
 
Upvote 0
Slightly different approach:
VBA Code: 
Sub CreateEmails()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, rng As Range, v As Variant, i As Long
    v = Range("D2", Range("D" & Rows.Count).End(xlUp)).Resize(, 5).Value
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
        For i = LBound(v) To UBound(v)
            If Not .exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                With ActiveSheet
                    .Range("A1").AutoFilter 4, v(i, 1)
                    Set rng = .AutoFilter.Range.Offset(1)
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .to = v(i, 5)
                        .Subject = "Enter your subject line here."
                        .HTMLBody = RangetoHTML(rng)
                        .Display
                    End With
                End With
            End If
        Next i
    End With
    ActiveSheet.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
Upvote 0
mumps said:
Slightly different approach:
VBA Code: 
Sub CreateEmails()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, rng As Range, v As Variant, i As Long
    v = Range("D2", Range("D" & Rows.Count).End(xlUp)).Resize(, 5).Value
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
        For i = LBound(v) To UBound(v)
            If Not .exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                With ActiveSheet
                    .Range("A1").AutoFilter 4, v(i, 1)
                    Set rng = .AutoFilter.Range.Offset(1)
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .to = v(i, 5)
                        .Subject = "Enter your subject line here."
                        .HTMLBody = RangetoHTML(rng)
                        .Display
                    End With
                End With
            End If
        Next i
    End With
    ActiveSheet.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
Click to expand...
Thanks you so much!! with this one i get to each email all the information that i needed.
 
Upvote 0
You are very welcome. :)
 
Upvote 0
Before you send me a private message, please follow this link to read the Forum rules, particularly Rule #4.
Message Board Rules
As long as any question you may have follows the Forum rules, you are welcome to send them to me.
 
Upvote 0
mumps said:
Before you send me a private message, please follow this link to read the Forum rules, particularly Rule #4.
Message Board Rules
As long as any question you may have follows the Forum rules, you are welcome to send them to me.
Click to expand...
Hello, I read all the rules, and is fine.. but dont know how to write you on private.
 
Upvote 0
You start a new “conversation”.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
vba, Email multiple addresses with multiple rows
2
Replies
13
Views
2K
mumps
mumps
willow1985
  • Solved
VBA Compile error - Trying to send an email using VBA/Excel
Replies
6
Views
519
gorgkhan
G
A
  • Question
Send multiple emails to clients with certain rows
Replies
1
Views
343
atditiljazi
A
A
  • Question
Email multiple addresses with multiple rows with VBA Macro
Replies
0
Views
398
atditiljazi
A
J
  • Question
How can I unite these two scripts to send emails with single or multiple attachments to a list of contacts?
Replies
8
Views
1K
JorgeMartinez
J

Forum statistics

Threads
1,214,431
Messages
6,119,457
Members
448,898
Latest member
drewmorgan128

Share this page

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
Back
Top