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

MADELEINECHAPMAN

New Member
Joined
May 26, 2021
Messages
2
Office Version
  1. 2019
Platform
  1. Windows
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 as per the below but would change pending on their customer code and the pricing that is showing on ‘sheet 1’


My current VB reads :

Sub SendEm()
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
Set Mail_Object = CreateObject("Outlook.Application")
For i = 2 To lr
With Mail_Object.CreateItem(o)
.Subject = Range("emailB1").Value
.To = Range("emailB2" & i).Value
.Body = Range("emailB3:I16").Value
'.Send
.display 'disable display and enable send to send automatically
End With
Next i
MsgBox "E-mail successfully sent", 64
Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub

Can VB do this or should I be looking at a different program?
I appreciate any support or advise.

Thank you. :)

Sheet 1

1622010702656.png




Excel Email:

1622010717869.png


What email should look like

1622010728162.png
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,262
Office Version
  1. 2007
Platform
  1. Windows
Hi and welcome to MrExcel.

Try the following code. Perhaps some details need to be adjusted.
First, you must have 2 sheets: "Sheet1" with the data. And sheet "Email" with the format for each email.
The data on sheet1 starts at row 9.

I don't know where you get the following data from:
Sheet "Email" cell B1, cells F5 to H5, cells in column E "In GST" in your example: "11.0583, 12.1836...."

VBA Code:
Sub sendmail()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim OutlookApp As Object, MItem As Object, dic As Object
  Dim rng As Range, ky As Variant
  Dim i As Long, lr As Long
   
  Application.ScreenUpdating = False
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Email")
  Set dic = CreateObject("Scripting.Dictionary")
  
  If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
  lr = sh1.Range("B" & Rows.Count).End(xlUp).Row
  For i = 10 To lr
    If sh1.Range("K" & i).Value = "X" Then
      dic(sh1.Range("B" & i).Value) = sh1.Range("C" & i).Value & "|" & sh1.Range("J" & i).Value
    End If
  Next
  
  For Each ky In dic.Keys
    sh2.Range("C8:E" & Rows.Count).ClearContents
    sh1.Range("A9").AutoFilter 2, ky
    sh1.Range("D10:D" & lr & ", I10:I" & lr).Copy
    sh2.Range("C8").PasteSpecial xlPasteValues
    sh2.Range("C3").Value = Split(dic(ky), "|")(0)  'name
    sh2.Range("B2").Value = Split(dic(ky), "|")(1)  'email
    sh2.Range("C4").Value = ky                      'number
    
    Set rng = sh2.Range("B3:I" & sh2.Range("C" & Rows.Count).End(xlUp).Row)
    Set OutlookApp = CreateObject("Outlook.Application")
    Set MItem = OutlookApp.CreateItem(0)
    With MItem
      .To = sh2.Range("B2").Value
      .Subject = sh2.Range("B1").Value
      .HTMLBody = RangetoHTML(rng)
      .Display
      '.Send
    End With
  Next
  sh1.ShowAllData
  Application.DisplayAlerts = False
  MsgBox "E-mail successfully sent"
End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006. Working in Office 2000-2016
  Dim fso As Object, ts As Object
  Dim TempFile As String, TempWB As Workbook
  
  TempFile = Environ$("temp") & "\temp.htm"
  'Copy the range and create a new workbook to past the data in
  rng.Copy
  Set TempWB = Workbooks.Add(1)
  With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
  End With
  
  'Publish the sheet to a htm file
  With TempWB.PublishObjects.Add(xlSourceRange, TempFile, TempWB.Sheets(1).Name, TempWB.Sheets(1).UsedRange.Address, xlHtmlStatic)
    .Publish (True)
  End With
  
  'Read all data from the htm file into RangetoHTML
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
  RangetoHTML = ts.readall
  ts.Close
  RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
  
  'Close TempWB
  TempWB.Close savechanges:=False
  'Delete the htm file we used in this function
  Kill TempFile
  Set ts = Nothing
  Set fso = Nothing
  Set TempWB = Nothing
End Function
 

MADELEINECHAPMAN

New Member
Joined
May 26, 2021
Messages
2
Office Version
  1. 2019
Platform
  1. Windows
Hi Dante,

Thank you so much for spending time on this for me. :)
Below is what each cell represents in the email tab, i'm not really sure how to adjust the details in the VB in order for it to reference it using the below tabel does your VB need adjusting ?
Thank you for you're help. :)

B1 =TYPED IN INFORMATION
B2=Sheet1!J10
B3=TYPED IN INFORMATION
C3=Sheet1!C10
B4=TYPED IN INFORMATION
C4=Sheet1!B10
B5=TYPED IN INFORMATION
B6 - E6 =TYPED IN INFORMATION
B7=TYPED IN INFORMATION
B8=TYPED IN INFORMATION
C8-C11TYPED IN INFORMATION
D8-D11LOOKS UP THE CUSTOMER NO AND PRODUCT AND RETURNED THE PRICE FROM SHEET1
E8-E11D*1.1
 

Forum statistics

Threads
1,136,445
Messages
5,675,900
Members
419,591
Latest member
mersanko

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
Top