Mail different clients with data pertaining to them only-Mail body

[amit_gupta123]

Hii

I was looking for the expert's opinion on the query. I have a client details in Sheet named "data". In sheet named "Mail" I have email Ids of those clients and my team. I am looking forward for automation of sending the emails to various clients.The Mails id(s) in To: tab is in Column B and in Cc tab in Collumn C. Subject line will remain same but with date change. Most important is the mail body that is message part and the table to be inserted in mail body which pertains to that clent only.

Please help. Attaching the sample file. The mail client I am using is Outlook.

Regards

 

[PCosta87]

Hii

I was looking for the expert's opinion on the query. I have a client details in Sheet named "data". In sheet named "Mail" I have email Ids of those clients and my team. I am looking forward for automation of sending the emails to various clients.The Mails id(s) in To: tab is in Column B and in Cc tab in Collumn C. Subject line will remain same but with date change. Most important is the mail body that is message part and the table to be inserted in mail body which pertains to that clent only.

Please help. Attaching the sample file. The mail client I am using is Outlook.

Regards

Hi,

Credit to Ron de Bruin for the RangetoHTML function!

The code below should work as intended:

Sub Send_Email()

    Dim c, rng As Range
    Dim OutLookApp As Object
    Dim OutLookMailItem As Object

    For Each c In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Cells
 
        Sheets("data").Columns("A:C").AutoFilter Field:=3, Criteria1:=c.Value
        Set rng = Sheets("data").Range("A1:B" & Sheets("data").Cells(Rows.Count, "A").End(xlUp).Row).Cells
 
        Set OutLookApp = CreateObject("Outlook.application")
        Set OutLookMailItem = OutLookApp.CreateItem(0)

        With OutLookMailItem
                .To = c.Offset(0, 1).Value
                .cc = c.Offset(0, 2).Value
                .Subject = c.Offset(0, 4).Value
                .HTMLBody = "Dear " & c.Value & "<br>" & c.Offset(0, 5).Value
                .HTMLBody = .HTMLBody & "<br>" & RangetoHTML(rng)
                .Display
    '            .Send
        End With
    Next c

End Sub

Function RangetoHTML(rng As Range)
' By Ron de Bruin.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".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( _
        SourceType:=xlSourceRange, _
        Filename:=TempFile, _
        Sheet:=TempWB.Sheets(1).Name, _
        Source:=TempWB.Sheets(1).UsedRange.Address, _
        HtmlType:=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

End Function

Change:

.Display
'.Send

to:

'.Display
.Send

If you do not wish to see the email window before sending the email.

Hope this helps

 

[amit_gupta123]

thankss...It's working on trial...will give a try on original data and get back..thanks Master

 

[PCosta87]

thankss...It's working on trial...will give a try on original data and get back..thanks Master

You are welcome

 

[amit_gupta123]

Hiii...I am back wit a small query...It's very much working fine but i have to make following changes manually:
Firstly, I have to change the font style from Times new roman to Zurich BT manually
Secondly, Spacing is created between salutation and paragraph on mail body
Thirdly, manually insert the closing lines after viz regards or ThANKING You

Can this be resolved.. I tried making changes but no success

 

[PCosta87]

Hi,

For the table, you can (as I did) simply change the font in excel before running the code.
As for the rest of the email, I made the necessary changes... please refer to attachment.

Hope this helps