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

[MADELEINECHAPMAN]

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

Excel Email:

What email should look like

 

[DanteAmor]

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...."

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]

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-C11	TYPED IN INFORMATION
D8-D11	LOOKS UP THE CUSTOMER NO AND PRODUCT AND RETURNED THE PRICE FROM SHEET1
E8-E11	D*1.1

 

[DanteAmor]

Did you try the macro?