VBA Macro to sort table by vendor copy table into email body and send, then do the same for the next vendor in the table to the last vendor

T

takingiwhanau

New Member
Joined
Aug 30, 2011
Messages
8
Office Version
  1. 365
Platform
  1. Windows
If I found code to send a single table from excel to outlook using HTML in the VBA Code. But I couldn't find code to sort the table to highlight each individual vendor and copy that table into the email body then move onto the next vendor till the last vendor is reached.

I have found the below code that will copy a filtered table and paste into the body of an email using HTML which is the end result I want for each different vendor. I can't figure out how to automate the macro to loop and filter the table to the next vendor in the table and then copy that lot of changed data to a new email.

Sub send_mass_email()
Dim i As Integer, cel As Range
Dim Name, Email, body, Subject, copy, Minesite, Workorder, str1, str2 As String
Dim OutApp As Object, OutMail As Object
Dim pop As Range

Set OutApp = CreateObject("Outlook.Application")

count_row = WorksheetFunction.CountA(Range("a1", Range("a1").End(xlDown)))
count_col = WorksheetFunction.CountA(Range("a1", Range("a1", "r1")))

Set pop = Sheets("Vendor Emails").Range(Cells(1, 5), Cells(count_row, count_col))

str1 = "<BODY style = font-size:12pt;font-family:Calibri>" & _
"Hello Team, <br><br> Can we please have an update on the purchase order/s below.<br>"

str2 = "<br>For further inforation please contact us below.<br>"

For Each cel In Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)

Email = Split(cel, " ")(0) 'extract first name
Name = cel.Offset(, 2).Value
Subject = cel.Offset(, 4).Value

Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = Email
.Subject = Subject & " " & Name & " PURCHASE ORDER UPDATES"
.display
.HTMLBody = str1 & RangetoHTML(pop) & str2 & .HTMLBody
'.Send
End With

If cel.Offset(1, 0).Value = cel.Offset(2, 0) Then
MsgBox "Email(s) Created!"
End
End If
If cel.Offset(1, 0).Value <> cel.Offset(2, 0) Then
MsgBox "Email(s) Created!"
End
End If

Next cel
MsgBox "Email(s) Created!"
End Sub
 

Attachments

  • Automate Filter Table Copy To Email Body.PNG
    Automate Filter Table Copy To Email Body.PNG
    60.6 KB · Views: 38

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
Sort by date Sort by votes
Try this:

VBA Code: 
Sub send_mass_email()
  Dim OutApp As Object, OutMail As Object
  Dim cel As Range, pop As Range
  Dim sName As String, Email As String, sSubj As String, str1 As String, str2 As String
  
  Dim sh1 As Worksheet
  Dim dic As Object
  Dim ky As Variant
  Dim lr As Long, lc As Long
  Dim dts As String
  
  Set OutApp = CreateObject("Outlook.Application")
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh1 = Sheets("Vendor Emails")
  
  If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
  lr = sh1.Range("A" & Rows.Count).End(3).Row
  lc = sh1.Cells(1, Columns.Count).End(1).Column
  str1 = "<BODY style = font-size:12pt;font-family:Calibri>" & _
    "Hello Team, <br><br> Can we please have an update on the purchase order/s below.<br>"
  str2 = "<br>For further inforation please contact us below.<br>"
  
  For Each cel In sh1.Range("B2:B" & lr)
    'store first email, vendor name, revision
    dts = Split(sh1.Range("A" & cel.Row).Value, " ")(0) & "|" & _
                sh1.Range("C" & cel.Row).Value & "|" & _
                sh1.Range("E" & cel.Row).Value
    dic(cel.Value) = dts
  Next cel
  
  For Each ky In dic.Keys
    sh1.Range("A1", sh1.Cells(lr, lc)).AutoFilter 2, ky
    Set pop = sh1.AutoFilter.Range.Range("E1", sh1.Cells(lr, lc))
    
    Email = Split(dic(ky), "|")(0)
    sName = Split(dic(ky), "|")(1)
    sSubj = Split(dic(ky), "|")(2)
    
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
      .To = Email
      .Subject = sSubj & " " & sName & " PURCHASE ORDER UPDATES"
      .Display
      .HTMLBody = str1 & RangetoHTML(pop) & str2 & .HTMLBody
      '.Send
    End With
  Next ky
  
  MsgBox "Email(s) Created!"
End Sub


--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
 
Upvote 0
Solution
Absolutely amazing that is exactly what I needed. you are a legend!!!!!
DanteAmor said:
Try this:

VBA Code: 
Sub send_mass_email()
  Dim OutApp As Object, OutMail As Object
  Dim cel As Range, pop As Range
  Dim sName As String, Email As String, sSubj As String, str1 As String, str2 As String
 
  Dim sh1 As Worksheet
  Dim dic As Object
  Dim ky As Variant
  Dim lr As Long, lc As Long
  Dim dts As String
 
  Set OutApp = CreateObject("Outlook.Application")
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh1 = Sheets("Vendor Emails")
 
  If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
  lr = sh1.Range("A" & Rows.Count).End(3).Row
  lc = sh1.Cells(1, Columns.Count).End(1).Column
  str1 = "<BODY style = font-size:12pt;font-family:Calibri>" & _
    "Hello Team, <br><br> Can we please have an update on the purchase order/s below.<br>"
  str2 = "<br>For further inforation please contact us below.<br>"
 
  For Each cel In sh1.Range("B2:B" & lr)
    'store first email, vendor name, revision
    dts = Split(sh1.Range("A" & cel.Row).Value, " ")(0) & "|" & _
                sh1.Range("C" & cel.Row).Value & "|" & _
                sh1.Range("E" & cel.Row).Value
    dic(cel.Value) = dts
  Next cel
 
  For Each ky In dic.Keys
    sh1.Range("A1", sh1.Cells(lr, lc)).AutoFilter 2, ky
    Set pop = sh1.AutoFilter.Range.Range("E1", sh1.Cells(lr, lc))
   
    Email = Split(dic(ky), "|")(0)
    sName = Split(dic(ky), "|")(1)
    sSubj = Split(dic(ky), "|")(2)
   
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
      .To = Email
      .Subject = sSubj & " " & sName & " PURCHASE ORDER UPDATES"
      .Display
      .HTMLBody = str1 & RangetoHTML(pop) & str2 & .HTMLBody
      '.Send
    End With
  Next ky
 
  MsgBox "Email(s) Created!"
End Sub


--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
Click to expand...
Absolutely amazing, that is exactly what I needed.
 
Upvote 0
takingiwhanau said:
Can I ask another favour? Can the displayed columns in the body of the email only be columns E:R?
Click to expand...

Change this:

Rich (BB code): 
Set pop = sh1.AutoFilter.Range.Range("E1", sh1.Cells(lr, "R"))

;)
 
Upvote 1
You must log in or register to reply here.

Similar threads

L
  • Solved
Macro to add table to email from excel. (stop at last row input)
Replies
9
Views
153
Luke1690
L
T
  • Question
VBA- Copy & Paste Range into Outlook as a Picture
Replies
1
Views
132
Domenic
D
P
  • Solved
Border/table in Email .Body
Replies
1
Views
179
Micron
M
A
  • Solved
Sending hyperlink filepath via email
Replies
8
Views
363
AndyEd
A
A
  • Question
runtime error 1004: application-defined or object-defined error
Replies
1
Views
479
Domenic
D

Forum statistics

Threads
1,215,073
Messages
6,122,970
Members
449,095
Latest member
Mr Hughes

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