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

josh921

New Member
Joined
Feb 24, 2011
Messages
31
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!
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Try this.
Change Sheet1 by the name of your sheet.

Code:
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
 
Upvote 0
Try this.
Change Sheet1 by the name of your sheet.

Code:
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?
 
Upvote 0
Check this:
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,255
Members
448,556
Latest member
peterhess2002

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