Email communication from Excel.

sur · Jan 12, 2023

Send a email for each person in the excel column B.

Note:
1. Person details in Column B.

Person Name	Person	Invoice Amount	Invoice#	Invoice Date	Invoice To	To	CC
A	1	1000	1234	1/12/2023	BB	CC@gmail.com	DD@gmail.com

2. Email ID
to - Column G
CC - Column H
3. email body should be like this.

Dear Person,

Thanks for doing Business,

Table from A to F

xxxxxxxxxxxxxxxxx

Thanks and Regards,

breynolds0431 · Jan 12, 2023

This should do it. The formatting in your table will be copied to the HTML body in the same format. I added a bottom border to the first row with the headers and the email generated like the attached image.

VBA Code:

Option Explicit

Sub EmailSend()

Dim ws As Worksheet: Set ws = ActiveSheet
Dim eList As Range: Set eList = ws.Range("B2:B" & ws.Cells(ws.Rows.Count, 2).End(xlUp).Row)
Dim hdr As Range: Set hdr = ws.Range("A1:F1")
Dim c As Range, iRow As Range

Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem:

For Each c In eList.Cells

    'Emails require adding the "Microsoft Outlook 16.0 Object Library" reference
    'This can be added in Tools > References
    Set oApp = CreateObject("Outlook.Application")
    Set oMail = oApp.CreateItem(olMailItem)
    
    With oMail
        .To = ws.Cells(c.Row, 7).Value
        .CC = ws.Cells(c.Row, 8).Value
        .Subject = ""
        .HTMLBody = "Dear " & ws.Cells(c.Row, 2) & "," & "<br>" & "<br>" & "Thanks for doing Business," & _
                     "<br>" & "<br>" & RangetoHTML(hdr) & RangetoHTML(ws.Range(ws.Cells(c.Row, 1), ws.Cells(c.Row, 6))) & _
                     "<br>" & "<br>" & "Thanks and Regards,"
        .Display
    End With

    Set oMail = Nothing
    Set oApp = Nothing

Next c

End Sub

Function RangetoHTML(rng As Range)
    
    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
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

sur · Jan 13, 2023

Thanks,l

breynolds0431 said:

This should do it. The formatting in your table will be copied to the HTML body in the same format. I added a bottom border to the first row with the headers and the email generated like the attached image.

View attachment 82653

VBA Code:

Option Explicit

Sub EmailSend()

Dim ws As Worksheet: Set ws = ActiveSheet
Dim eList As Range: Set eList = ws.Range("B2:B" & ws.Cells(ws.Rows.Count, 2).End(xlUp).Row)
Dim hdr As Range: Set hdr = ws.Range("A1:F1")
Dim c As Range, iRow As Range

Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem:

For Each c In eList.Cells

    'Emails require adding the "Microsoft Outlook 16.0 Object Library" reference
    'This can be added in Tools > References
    Set oApp = CreateObject("Outlook.Application")
    Set oMail = oApp.CreateItem(olMailItem)
   
    With oMail
        .To = ws.Cells(c.Row, 7).Value
        .CC = ws.Cells(c.Row, 8).Value
        .Subject = ""
        .HTMLBody = "Dear " & ws.Cells(c.Row, 2) & "," & "<br>" & "<br>" & "Thanks for doing Business," & _
                     "<br>" & "<br>" & RangetoHTML(hdr) & RangetoHTML(ws.Range(ws.Cells(c.Row, 1), ws.Cells(c.Row, 6))) & _
                     "<br>" & "<br>" & "Thanks and Regards,"
        .Display
    End With

    Set oMail = Nothing
    Set oApp = Nothing

Next c

End Sub

Function RangetoHTML(rng As Range)
   
    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
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Thanks for the Code, few clarification or modification needed on this.

1. there is instance where the Person A is recurring those cases, it should filter by Person Name and make the table.

2. currently the table is having one row gap between the header and person details, which should not be.

3. Can we have the hyperlink in Column L so that it should filter for that person details and send a email of the person details.

Person Name	Person	Invoice Amount	Invoice#	Invoice Date	Invoice To	To	CC	HyperLink
A	1	1000	1234	1/12/2023	BB	CC@gmail.com	DD@gmail.com	Send email
B	1	1000	1234	1/12/2023	BB	CC@gmail.com	DD@gmail.com	Send email
A	1	1000	1234	1/12/2023	BB	CC@gmail.com	DD@gmail.com	Send email

Request you to help on the above.

breynolds0431 · Jan 13, 2023

Try this. It's kind of a pain to set the hyperlinks up. They need to be set to Place in This Document with the Cell Reference set to the cell that the hyperlink is in.

Next, you'll have a Worksheet_FollowHyperlink() event in the worksheet module of the sheet with the list of names and add this code to it.

VBA Code:

Public tRow As Integer

'This will require the setting each hyperlink to Place in This Document
'with thc Cell Reference = Cell that Hyperlink is in

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)

tRow = ActiveCell.Row
Call EmailSend(tRow)

End Sub

Then, you can probably include this in the same module, but I have it in a normal (non-sheet) module:

VBA Code:

Option Explicit

Sub EmailSend(ByVal tRow As Integer)

Dim ws As Worksheet: Set ws = ActiveSheet
Dim lrow As Long: lrow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
Dim c As Range

'Error handling
On Error GoTo rThings

'turn off screen updating
Application.ScreenUpdating = False

'Hide all rows not equal to tRow
For Each c In ws.Range("A2:I" & lrow).Cells
    If c.Row <> tRow Then Rows(c.Row).EntireRow.Hidden = True
Next c

Dim eList As Range: Set eList = ws.Range("A1:F" & lrow)
Set eList = eList.SpecialCells(xlCellTypeVisible)

    'Emails require adding the "Microsoft Outlook 16.0 Object Library" reference
    'This can be added in Tools > References
    Dim oApp As Outlook.Application: Set oApp = CreateObject("Outlook.Application")
    Dim oMail As Outlook.MailItem: Set oMail = oApp.CreateItem(olMailItem)
   
    With oMail
        .To = ws.Cells(tRow, 7).Value
        .CC = ws.Cells(tRow, 8).Value
        .Subject = ""
        .HTMLBody = "Dear " & ws.Cells(tRow, 2) & "," & "<br>" & "<br>" & "Thanks for doing Business," & _
                     "<br>" & "<br>" & RangetoHTML(eList) & "<br>" & "<br>" & "Thanks and Regards,"
        .Display
    End With

    Set oMail = Nothing
    Set oApp = Nothing

'Show all rows after email
For Each c In ws.Range("A1:I" & lrow + 1).Cells
    Rows(c.Row).EntireRow.Hidden = False
Next c

'turn screen updating back on
Application.ScreenUpdating = True

Exit Sub

'error handling
rThings:
MsgBox "The below error has occurred: " & vbCrLf & vbCrLf & "Error Number:" & Err.Number & vbCrLf & _
    "Error Description: " & Err.Description
Application.ScreenUpdating = True

End Sub

Function RangetoHTML(rng As Range)
   
    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
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

sur · Jan 14, 2023

This is working, but it is not combing the HTMP Table the by the Person A,

if we have the table like below:

Person Name	Person	Invoice Amount	Invoice#	Invoice Date	Invoice To
A	1	1000	1234	1/12/2023	BB
B	2	1000	1234	1/12/2023	BB
A	1	1000	1234	1/12/2023	BB

breynolds0431 · Jan 14, 2023

Sorry, I misunderstood. But that makes sense to send one email for each person. I updated the below to filter by column A and add that to the email body. You'd still need the Worksheet_Followhyperlink() event to call the EmailSend() event.

VBA Code:

Option Explicit

Sub EmailSend(ByVal tRow As Integer)

Dim ws As Worksheet: Set ws = ActiveSheet
Dim lrow As Long: lrow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
Dim c As Range

'Error handling
On Error GoTo rThings

'turn off screen updating
Application.ScreenUpdating = False

'Turns off autofilter if already set
If ws.AutoFilterMode Then ws.AutoFilterMode = False
'Filter results by tRow's name
ws.Range("A1:I4" & lrow).AutoFilter Field:=1, Criteria1:=ws.Cells(tRow, 1)

Dim eList As Range: Set eList = ws.Range("A1:F" & lrow)
Set eList = eList.SpecialCells(xlCellTypeVisible)

    'Emails require adding the "Microsoft Outlook 16.0 Object Library" reference
    'This can be added in Tools > References
    Dim oApp As Outlook.Application: Set oApp = CreateObject("Outlook.Application")
    Dim oMail As Outlook.MailItem: Set oMail = oApp.CreateItem(olMailItem)
   
    With oMail
        .To = ws.Cells(tRow, 7).Value
        .CC = ws.Cells(tRow, 8).Value
        .Subject = ""
        .HTMLBody = "Dear " & ws.Cells(tRow, 2) & "," & "<br>" & "<br>" & "Thanks for doing Business," & _
                     "<br>" & "<br>" & RangetoHTML(eList) & "<br>" & "<br>" & "Thanks and Regards,"
        .Display
    End With

    Set oMail = Nothing
    Set oApp = Nothing

'Clears Filter
ws.AutoFilterMode = False

'turn screen updating back on
Application.ScreenUpdating = True

Exit Sub

'error handling
rThings:
MsgBox "The below error has occurred: " & vbCrLf & vbCrLf & "Error Number:" & Err.Number & vbCrLf & _
    "Error Description: " & Err.Description
Application.ScreenUpdating = True

End Sub

Function RangetoHTML(rng As Range)
   
    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
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

sur · Jan 15, 2023

Thanks this is working fine,

I did tried to add change the font for the body and one line hyperlink in the body of the email and found it difficult, can you help me

Dear,

Thanks for Doing Business.
Table
Hyperlink for website.
Please continue doing business.

thanks & Regards.

breynolds0431 · Jan 15, 2023

VBA Code:

Option Explicit

Sub EmailSend(ByVal tRow As Integer)

Dim ws As Worksheet: Set ws = ActiveSheet
Dim lrow As Long: lrow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
Dim c As Range

'Error handling
On Error GoTo rThings

'turn off screen updating
Application.ScreenUpdating = False

'Turns off autofilter if already set
If ws.AutoFilterMode Then ws.AutoFilterMode = False
'Filter results by tRow's name
ws.Range("A1:I4" & lrow).AutoFilter Field:=1, Criteria1:=ws.Cells(tRow, 1)

Dim eList As Range: Set eList = ws.Range("A1:F" & lrow)
Set eList = eList.SpecialCells(xlCellTypeVisible)

    'Emails require adding the "Microsoft Outlook 16.0 Object Library" reference
    'This can be added in Tools > References
    Dim oApp As Outlook.Application: Set oApp = CreateObject("Outlook.Application")
    Dim oMail As Outlook.MailItem: Set oMail = oApp.CreateItem(olMailItem)
   
    With oMail
        .To = ws.Cells(tRow, 7).Value
        .CC = ws.Cells(tRow, 8).Value
        .Subject = ""
        .HTMLBody = "<p style='font-family:calibri;font-size:11'>" & "Dear " & _
                    ws.Cells(tRow, 2) & "," & "<br>" & "<br>" & "Thanks for doing " & _
                    "Business," & RangetoHTML(eList) & "<p style='font-family:calibri;" & _
                    "font-size:11'>" & "<br>" & "<a href=""www.yourbusiness.com"">" & _
                    "Visible Text </a>" & "<br>" & "<br>" & "Please continue doing " & _
                    "business." & "<br>" & "<br>" & "Thanks and Regards," & "</p>" & "</p>"
        .Display
    End With

    Set oMail = Nothing
    Set oApp = Nothing

'Clears Filter
ws.AutoFilterMode = False

'turn screen updating back on
Application.ScreenUpdating = True

Exit Sub

'error handling
rThings:
MsgBox "The below error has occurred: " & vbCrLf & vbCrLf & "Error Number:" & Err.Number & vbCrLf & _
    "Error Description: " & Err.Description
Application.ScreenUpdating = True

End Sub

Function RangetoHTML(rng As Range)
   
    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
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

sur · Feb 28, 2023

Thanks Verymuch,

can we have the default font to Arial, 10 Size in the body of the email ?

Email communication from Excel.

sur

Board Regular

Excel Facts

breynolds0431

Active Member

sur

Board Regular

breynolds0431

Active Member

sur

Board Regular

breynolds0431

Active Member

sur

Board Regular

breynolds0431

Active Member

sur

Board Regular

Similar threads

Forum statistics

Share this page

Email communication from Excel.

Board Regular

Excel Facts

Active Member

Board Regular

Active Member

Board Regular

Active Member

Board Regular

Active Member

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock