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: 52

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
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
You must log in or register to reply here.

Similar threads

P
  • Solved
What does this code do or mean
Replies
2
Views
181
Perrister
P
L
  • Question Question
Sending Email with Table in Body
Replies
3
Views
781
Domenic
D
D
  • Solved
VBA to paste table into Outlook
Replies
5
Views
821
Dani_LobP
D
J
  • Question Question
Send bulk email attachment error
Replies
3
Views
114
JOHATUP
J
S
  • Question Question
VBA sending an email of two conditions are met
Replies
5
Views
292
mumps
mumps

Forum statistics

Threads
1,224,821
Messages
6,181,163
Members
453,021
Latest member
Justyna P

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