Is there VBA to create multiple emails of specific cells based on email address in the same row?

[josh921]

I have a worksheet with almost 1000 rows of data (userids) in column B and locations for that data in column C.
In column A, I have email addresses for the owners of B. (there are 300 unique email addresses).
I'm not super awesome at VBA, but assume that there is VBA to "extract" the unique email addresses one at a time (i.e. create 300 emails) and insert the specific values from B and C where A matches the unique email address.

Thanks in advance!

 

[DanteAmor]

Try this.
Change Sheet1 by the name of your sheet.

Sub create_multiple_emails()
  Dim c As Range, sh As Worksheet, ky As Variant, m As Range, sBody As String
  Dim dam As Object, dict As Object
    
  Set sh = Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")
  Set dict = CreateObject("scripting.dictionary")
  For Each c In sh.Range("A2", sh.Range("A" & Rows.Count).End(xlUp))
    If Not dict.exists(c.Value) Then
      dict(c.Value) = dict(c.Value)
      sBody = "Userids - Locations" & vbCr
      sh.Range("A1").AutoFilter 1, c
      For Each m In sh.Range("B2", sh.Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        sBody = sBody & m.Value & " - " & m.Offset(, 1).Value & vbCr
      Next
      
      Set dam = CreateObject("Outlook.Application").CreateItem(0)
      dam.To = c
      dam.Subject = "Subject"
      dam.body = sBody
      'dam.Send 'to send
      dam.display 'to show
    End If
  Next
  sh.ShowAllData
End Sub

 

[SteynBS]

Try this.
Change Sheet1 by the name of your sheet.

Sub create_multiple_emails()
  Dim c As Range, sh As Worksheet, ky As Variant, m As Range, sBody As String
  Dim dam As Object, dict As Object
   
  Set sh = Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")
  Set dict = CreateObject("scripting.dictionary")
  For Each c In sh.Range("A2", sh.Range("A" & Rows.Count).End(xlUp))
    If Not dict.exists(c.Value) Then
      dict(c.Value) = dict(c.Value)
      sBody = "Userids - Locations" & vbCr
      sh.Range("A1").AutoFilter 1, c
      For Each m In sh.Range("B2", sh.Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        sBody = sBody & m.Value & " - " & m.Offset(, 1).Value & vbCr
      Next
     
      Set dam = CreateObject("Outlook.Application").CreateItem(0)
      dam.To = c
      dam.Subject = "Subject"
      dam.body = sBody
      'dam.Send 'to send
      dam.display 'to show
    End If
  Next
  sh.ShowAllData
End Sub

Hi Dante,

I have a similar issue, but I would like to paste a table instead of extracting the information, can this be done?

 

[DanteAmor]

Check this:

VB help -sending email with multiple rows to multiple users changes

Hi Everyone, I am trying to create a VB with very little VB experience. I would like the VB to create an email for each different email address that is on “sheet 1” with the data relating to their customer code if it has a ‘x’ in the send price advice code column. Each email would need to show...

www.mrexcel.com