Change my email macro to email multiple recipients in different rows

Jyggalag

Jyggalag

Active Member
Joined
Mar 8, 2021
Messages
445
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Hi all!

I currently have this setup in Excel:

1643122160094.png


And the code is this:

VBA Code: 
Option Explicit

Private Const FilePath As String = "\\COMPANY.MSAD.COMPANY.NET\userdata\t543932\home\Documents\TESTfolder\"
Sub send_email_complete()
Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Long
    Dim ws As Worksheet
   
    '~~> Change this to the relevant worksheet
    '~~> that has the emails (right now Sheet1 has it)
    Set ws = ThisWorkbook.Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")
   
    '~~> Looping from rows 2 to 10 (update if necessary)
    For i = 2 To 10
        '~~> This creates a new email (so we can send out multiple emails)
        Set OutMail = OutApp.CreateItem(0)

With OutMail
.To = ws.Cells(i, 15).Value2 & ";" & ws.Cells(i, 16).Value2 & ";" & ws.Cells(i, 17).Value2
.BCC = ws.Cells(i, 18).Value2
.Subject = ws.Cells(i, 13).Value2
.HTMLBody = "Dear all,<br/>" & "<BR>" & _
"Insignificant text not necessary for this example code<br/>" & "<BR>" & _
"Kind regards</br>" & "<BR>"
.Attachments.Add FilePath & ws.Cells(2, 19).Value2

.Display

End With
Next i

End Sub

The issue that I have right now, is that I want to send emails to each division (so right now a total of 10 emails to 30 recipients). However, in my real structure, I have AT MAX 3 emails per row, which means that some companies will be duplicated, as seen above, into the next 1-2 rows for further emails (I always have between 1-9 emails for each recipient (company in example above)).

Can somebody help me change my code so it can detect when the company is the same and then merge the emails together? So for company 1 it should send the email to 6 recipients, instead of 3, for example :)

@Siddharth Rout if you're available as well it would be greatly appreciated! :)

Kind regards,
Jyggalag
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
Sort by date Sort by votes
I can give you the code but would you like to try it first?

LOGIC
  1. Create a unique collection of company names from N either using DICTIONARY or COLLECTION
  2. Use 2 loops. First loop to go through companies. 2nd Loop to go through rows
  3. Use 2 variables. One for TO and one for BCC. In the loop simply populate these variables.
  4. Finally generate the email
 
Upvote 0
Siddharth Rout said:
I can give you the code but would you like to try it first?

LOGIC
  1. Create a unique collection of company names from N either using DICTIONARY or COLLECTION
  2. Use 2 loops. First loop to go through companies. 2nd Loop to go through rows
  3. Use 2 variables. One for TO and one for BCC. In the loop simply populate these variables.
  4. Finally generate the email
Click to expand...
I am really bad at coding so I would appreciate if I could get it haha, not sure what the first line with dictionary or collection means

I started in VBA 3 days ago :) But I am writing down every code in a formula sheet for myself so I can learn from my mistakes!
 
Upvote 0
As a special gesture, I will give you the code this time but next time you will have to show efforts before I assist you ? Trust me this is for your own good!

Is this what you are trying? (UNTESTED)

VBA Code: 
Option Explicit

Private Const FilePath As String = "\\COMPANY.MSAD.COMPANY.NET\userdata\t543932\home\Documents\TESTfolder\"

Sub send_email_complete()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Long
    Dim ws As Worksheet
    Dim col As New Collection, itm As Variant
    Dim ToAddress As String, BCCAddress As String, EmailSubject As String
    
    '~~> Change this to the relevant worksheet
    '~~> that has the emails (right now Sheet1 has it)
    Set ws = ThisWorkbook.Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")
   
    '~~> Looping from rows 2 to 10 to create a unique collection of company names
    For i = 2 To 10
        On Error Resume Next
        col.Add ws.Cells(i, 14).Value2, CStr(ws.Cells(i, 14).Value2)
        On Error GoTo 0
    Next i
     
    '~~> Looping through the company names
    For Each itm In col
        '~~> Resetting the to and bcc address and the subject
        ToAddress = "": BCCAddress = "": EmailSubject = ""
        
        '~~> Constructing your addresses and subject
        For i = 2 To 10
            '~~> Check if the company name matches
            If ws.Cells(i, 14).Value2 = itm Then
                ToAddress = ToAddress & ";" & _
                            ws.Cells(i, 15).Value2 & ";" & ws.Cells(i, 16).Value2 & ";" & ws.Cells(i, 17).Value2
                            
                BCCAddress = BCCAddress & ";" & _
                             ws.Cells(i, 18).Value2
                             
                If EmailSubject = "" Then EmailSubject = ws.Cells(i, 13).Value2
            End If
        Next i
        
        '~~> Removing the first ";"
        ToAddress = Mid(ToAddress, 2)
        BCCAddress = Mid(BCCAddress, 2)
        
        '~~> This creates a new email (so we can send out multiple emails)
        Set OutMail = OutApp.CreateItem(0)

        With OutMail
            .To = ToAddress
            .BCC = BCCAddress
            .Subject = EmailSubject
            .HTMLBody = "Dear all,<br/>" & "<BR>" & _
                "Insignificant text not necessary for this example code<br/>" & "<BR>" & _
                "Kind regards</br>" & "<BR>"
            .Attachments.Add FilePath & ws.Cells(2, 19).Value2

            .Display
        End With
    Next itm
End Sub
 
Upvote 0
Solution
Siddharth Rout said:
As a special gesture, I will give you the code this time but next time you will have to show efforts before I assist you ? Trust me this is for your own good!

Is this what you are trying? (UNTESTED)

VBA Code: 
Option Explicit

Private Const FilePath As String = "\\COMPANY.MSAD.COMPANY.NET\userdata\t543932\home\Documents\TESTfolder\"

Sub send_email_complete()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Long
    Dim ws As Worksheet
    Dim col As New Collection, itm As Variant
    Dim ToAddress As String, BCCAddress As String, EmailSubject As String
  
    '~~> Change this to the relevant worksheet
    '~~> that has the emails (right now Sheet1 has it)
    Set ws = ThisWorkbook.Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")
 
    '~~> Looping from rows 2 to 10 to create a unique collection of company names
    For i = 2 To 10
        On Error Resume Next
        col.Add ws.Cells(i, 14).Value2, CStr(ws.Cells(i, 14).Value2)
        On Error GoTo 0
    Next i
   
    '~~> Looping through the company names
    For Each itm In col
        '~~> Resetting the to and bcc address and the subject
        ToAddress = "": BCCAddress = "": EmailSubject = ""
      
        '~~> Constructing your addresses and subject
        For i = 2 To 10
            '~~> Check if the company name matches
            If ws.Cells(i, 14).Value2 = itm Then
                ToAddress = ToAddress & ";" & _
                            ws.Cells(i, 15).Value2 & ";" & ws.Cells(i, 16).Value2 & ";" & ws.Cells(i, 17).Value2
                          
                BCCAddress = BCCAddress & ";" & _
                             ws.Cells(i, 18).Value2
                           
                If EmailSubject = "" Then EmailSubject = ws.Cells(i, 13).Value2
            End If
        Next i
      
        '~~> Removing the first ";"
        ToAddress = Mid(ToAddress, 2)
        BCCAddress = Mid(BCCAddress, 2)
      
        '~~> This creates a new email (so we can send out multiple emails)
        Set OutMail = OutApp.CreateItem(0)

        With OutMail
            .To = ToAddress
            .BCC = BCCAddress
            .Subject = EmailSubject
            .HTMLBody = "Dear all,<br/>" & "<BR>" & _
                "Insignificant text not necessary for this example code<br/>" & "<BR>" & _
                "Kind regards</br>" & "<BR>"
            .Attachments.Add FilePath & ws.Cells(2, 19).Value2

            .Display
        End With
    Next itm
End Sub
Click to expand...
Thank you so much!

I tried the code, but it comes up with this error:
1643181434906.png

Any idea why? My full code is:

VBA Code: 
Option Explicit

Private Const FilePath As String = "\\COMPANY.MDSS.COMPANY.NET\userdata\t5483493\home\Documents\TESTfolder\"
Sub send_email_complete()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Long
    Dim ws As Worksheet
    Dim col As New Collection, itm As Variant
    Dim ToAddress As String, BCCAddress As String, EmailSubject As String
  
    '~~> Change this to the relevant worksheet
    '~~> that has the emails (right now Sheet1 has it)
    Set ws = ThisWorkbook.Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")
   
    '~~> Looping from rows 2 to 10 to create a unique collection of company names
    For i = 2 To 10
        On Error Resume Next
        col.Add ws.Cells(i, 14).Value2, CStr(ws.Cells(i, 14).Value2)
        On Error GoTo 0
    Next i
   
    '~~> Looping through the company names
    For Each itm In col
        '~~> Resetting the to and bcc address and the subject
        ToAddress = "": BCCAddress = "": EmailSubject = ""
       
    '~~> Constructing your addresses and subject
        For i = 2 To 10
            '~~> Check if the company name matches
            If ws.Cells(i, 14).Value2 = itm Then
                ToAddress = ToAddress & ";" & _
                            ws.Cells(i, 15).Value2 & ";" & ws.Cells(i, 16).Value2 & ";" & ws.Cells(i, 17).Value2
                           
                BCCAddress = BCCAddress & ";" & _
                             ws.Cells(i, 18).Value2
                            
                If EmailSubject = "" Then EmailSubject = ws.Cells(i, 13).Value2
            End If
        Next i
       
          '~~> Removing the first ";"
        ToAddress = Mid(ToAddress, 2)
        BCCAddress = Mid(BCCAddress, 2)
  
    '~~> Looping from rows 2 to 10 (update if necessary)
    For i = 2 To 10
        '~~> This creates a new email (so we can send out multiple emails)
        Set OutMail = OutApp.CreateItem(0)

With OutMail
.To = ToAddress
.BCC = BCCAddress
.Subject = EmailSubject
.HTMLBody = "Dear all,<br/>" & "<BR>" & _
"bunch of text" & "<BR>" & _
"Kind regards</br>" & "<BR>"
.Attachments.Add FilePath & ws.Cells(2, 19).Value2

.Display

End With
Next itm

End Sub
 
Upvote 0
That's not Sid's code - you duplicated the For i = ... line for some reason.
 
Upvote 0
Jyggalag said:
Thank you so much!

I tried the code, but it comes up with this error: View attachment 56147
Any idea why? My full code is:

VBA Code: 
Option Explicit

Private Const FilePath As String = "\\COMPANY.MDSS.COMPANY.NET\userdata\t5483493\home\Documents\TESTfolder\"
Sub send_email_complete()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Long
    Dim ws As Worksheet
    Dim col As New Collection, itm As Variant
    Dim ToAddress As String, BCCAddress As String, EmailSubject As String
 
    '~~> Change this to the relevant worksheet
    '~~> that has the emails (right now Sheet1 has it)
    Set ws = ThisWorkbook.Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")
 
    '~~> Looping from rows 2 to 10 to create a unique collection of company names
    For i = 2 To 10
        On Error Resume Next
        col.Add ws.Cells(i, 14).Value2, CStr(ws.Cells(i, 14).Value2)
        On Error GoTo 0
    Next i
 
    '~~> Looping through the company names
    For Each itm In col
        '~~> Resetting the to and bcc address and the subject
        ToAddress = "": BCCAddress = "": EmailSubject = ""
   
    '~~> Constructing your addresses and subject
        For i = 2 To 10
            '~~> Check if the company name matches
            If ws.Cells(i, 14).Value2 = itm Then
                ToAddress = ToAddress & ";" & _
                            ws.Cells(i, 15).Value2 & ";" & ws.Cells(i, 16).Value2 & ";" & ws.Cells(i, 17).Value2
                       
                BCCAddress = BCCAddress & ";" & _
                             ws.Cells(i, 18).Value2
                        
                If EmailSubject = "" Then EmailSubject = ws.Cells(i, 13).Value2
            End If
        Next i
   
          '~~> Removing the first ";"
        ToAddress = Mid(ToAddress, 2)
        BCCAddress = Mid(BCCAddress, 2)
 
    '~~> Looping from rows 2 to 10 (update if necessary)
    For i = 2 To 10
        '~~> This creates a new email (so we can send out multiple emails)
        Set OutMail = OutApp.CreateItem(0)

With OutMail
.To = ToAddress
.BCC = BCCAddress
.Subject = EmailSubject
.HTMLBody = "Dear all,<br/>" & "<BR>" & _
"bunch of text" & "<BR>" & _
"Kind regards</br>" & "<BR>"
.Attachments.Add FilePath & ws.Cells(2, 19).Value2

.Display

End With
Next itm

End Sub
Click to expand...

That is because you copied my code incorrectly. :)

1643186410117.png


If you want to learn whats going on then I would recommend trying to undertsand what the code is doing. Also indenting your code will help you understand the code structure.
 
Upvote 0
Siddharth Rout said:
That is because you copied my code incorrectly. :)

View attachment 56154

If you want to learn whats going on then I would recommend trying to undertsand what the code is doing. Also indenting your code will help you understand the code structure.
Click to expand...
It works!!

Thank you so much!! This is amazing!

I will say, that this is by far the most complex code I have ever used, and I'm still learning VBA (for example, I had no idea you could type .To and .Bcc without having the variable before, for example SendEmailTo.to = mymail@gmail.com. But I appreciate your help so much! I will try to research some of the codes that you use and write them down, if you could recommend any training sites for VBA or likewise, it would be greatly appreciated :)

Have a great Wednesday!
 
Upvote 0
Jyggalag said:
It works!!

Thank you so much!! This is amazing!

I will say, that this is by far the most complex code I have ever used, and I'm still learning VBA (for example, I had no idea you could type .To and .Bcc without having the variable before, for example SendEmailTo.to = mymail@gmail.com. But I appreciate your help so much! I will try to research some of the codes that you use and write them down, if you could recommend any training sites for VBA or likewise, it would be greatly appreciated :)

Have a great Wednesday!
Click to expand...

Thanks for taking the time out for the feedback.

I always recommned john-walkenbach-books when someone asks me for a recommnedation. I am sure other experts will have other suggestions as well...
 
Upvote 0
Bill and Tracy have a number of good books in the MrE store. :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
VBA sending an email of two conditions are met
Replies
5
Views
136
mumps
mumps
B
  • Solved
VBA to email recipient if column cells contain value
Replies
6
Views
537
bh24524
B
The Ruff Report
  • Question Question
Help adjusting Macro to email multiple cc addresses
Replies
1
Views
885
The Ruff Report
The Ruff Report
B
  • Solved
VBA Email Outllook Item .Send does not work
Replies
3
Views
871
Anfinsen
A
S
  • Question Question
Excel VBA to email multiple ranges as a PDF
Replies
0
Views
956
shophoney
S

Forum statistics

Threads
1,223,884
Messages
6,175,174
Members
452,615
Latest member
bogeys2birdies

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