VBA/Macro Email body range selection

arsentievalex

New Member
Joined
Mar 18, 2020
Messages
15
Office Version
  1. 365
Platform
  1. Windows
Hello,

I'm trying to set up a macro that would send an outlook email. I've run into an issue when adding a table from sheet2 to the email body code. Basically, what I want to accomplish is an email that contains two tables from sheet1 and sheet2, sheet1 works perfectly, however, sheet2 does not pull through for some reason. I'm using code in two modules, one for email and other for range selection. I'm attaching the codes that I'm using. I believe, the issue is that I need to select sheet2 somewhere but cannot find it. Any help would be greatly appreciated :)

VBA Code:
Sub Email_range()

Dim OutApp As Object

Dim OutMail As Object

Dim count_row, count_col As Integer

Dim table1 As Range

Dim table2 As Range

Dim str1, str2, str3 As String



Set OutApp = CreateObject("Outlook.Application")

Set OutMail = OutApp.CreateItem(0)



count_row = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))

count_col = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlToRight)))





Set table1 = Sheets("Sheet1").Range(Cells(1, 1), Cells(count_row, count_col))



Set table2 = Sheets("Sheet2").Range(Cells(1, 1), Cells(count_row, count_col))



str1 = "<BODY STYLE = font-size12pt/font-family:Calibri>" & _

"Good morning,”<br>



str2 = "<br>Please see below."<br>



str3 = "<br>Best regards."



On Error Resume Next

With OutMail

   .to = "[EMAIL]thisistest@test.com[/EMAIL]"

   .CC = " "

   .Subject = "Daily Report"

   .Display

   .HTMLBody = str1 & RangetoHTML(table2) & str2 & RangetoHTML(table1) & .HTMLBody



End With

On Error GoTo 0



Set OutMail = Nothing

Set OutApp = Nothing



End Sub

VBA Code:
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
 
Last edited by a moderator:

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).

arsentievalex

New Member
Joined
Mar 18, 2020
Messages
15
Office Version
  1. 365
Platform
  1. Windows
Sorry, the code below:

VBA Code:
Sub Email_range()

Dim OutApp As Object

Dim OutMail As Object

Dim count_row, count_col As Integer

Dim table1 As Range

Dim table2 As Range

Dim str1, str2, str3 As String



Set OutApp = CreateObject("Outlook.Application")

Set OutMail = OutApp.CreateItem(0)



count_row = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))

count_col = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlToRight)))





Set table1 = Sheets("Sheet1").Range(Cells(1, 1), Cells(count_row, count_col))



Set table2 = Sheets("Sheet2").Range(Cells(1, 1), Cells(count_row, count_col))



str1 = "<BODY STYLE = font-size12pt/font-family:Calibri>" & _

"Good morning,”<br>



str2 = "<br>Please see below."<br>



str3 = "<br>Best regards."



On Error Resume Next

With OutMail

   .to = "thisistest@test.com"

   .CC = " "

   .Subject = "Daily Report"

   .Display

   .HTMLBody = str1 & RangetoHTML(table2) & str2 & RangetoHTML(table1) & .HTMLBody



End With

On Error GoTo 0



Set OutMail = Nothing

Set OutApp = Nothing



End Sub

VBA Code:
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
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
The problem you are having is I think due to the fact that you are not using a reference for Sheet2. Try this:
VBA Code:
Sub Email_range()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim count_row, count_col As Integer
    Dim table1 As Range
    Dim table2 As Range
    Dim str1, str2, str3 As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With Sheets("Sheet1")
        count_row = WorksheetFunction.CountA(.Range("A1", .Range("A1").End(xlDown)))
        count_col = WorksheetFunction.CountA(.Range("A1", .Range("A1").End(xlToRight)))
        Set table1 = .Range(Cells(1, 1), Cells(count_row, count_col))
    End With

    With Sheets("Sheet2")
        count_row = WorksheetFunction.CountA(.Range("A1", .Range("A1").End(xlDown)))
        count_col = WorksheetFunction.CountA(.Range("A1", .Range("A1").End(xlToRight)))
        Set table2 = .Range(Cells(1, 1), Cells(count_row, count_col))
    End With

    str1 = "<BODY STYLE = font-size12pt/font-family:Calibri>" & "Good morning,<br>”"
    str2 = "<br>Please see below.<br>"
    str3 = "<br>Best regards."

    On Error Resume Next
    With OutMail
        .to = "thisistest@test.com"
        .CC = " "
        .Subject = "Daily Report"
        .Display
        .HTMLBody = str1 & RangetoHTML(table2) & str2 & RangetoHTML(table1) & .HTMLBody
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
 

Zack Barresse

MrExcel MVP
Joined
Dec 9, 2003
Messages
10,881
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
  2. Mobile
  3. Web
This is a common mistake. Your range objects are not being set properly. There are assumptions there, namely the Cells method being used inside the Range method. Those need qualified as well, otherwise it assumes the worksheet for that object is the active worksheet.

Offending code:
VBA Code:
    Set table1 = Sheets("Sheet1").Range(Cells(1, 1), Cells(count_row, count_col))
    Set table2 = Sheets("Sheet2").Range(Cells(1, 1), Cells(count_row, count_col))

Updated to explicitly set range object references:
VBA Code:
    Set table1 = Sheets("Sheet1").Range(Sheets("Sheet1").Cells(1, 1), Sheets("Sheet1").Cells(count_row, count_col))
    Set table2 = Sheets("Sheet2").Range(Sheets("Sheet2").Cells(1, 1), Sheets("Sheet2").Cells(count_row, count_col))
 

arsentievalex

New Member
Joined
Mar 18, 2020
Messages
15
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Indeed, it was missing sheet reference. The code works now as it should. many thanks for your help!
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
Glad we could help and thanks for letting us know.
 

arsentievalex

New Member
Joined
Mar 18, 2020
Messages
15
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

@Zack Barresse @GWteB One more question, would you know if it is possible to paste the table as image to the email?
 

arsentievalex

New Member
Joined
Mar 18, 2020
Messages
15
Office Version
  1. 365
Platform
  1. Windows
I'm also trying to find a way to past the tables as separate filtered entries with the header. Like below:

1584871023793.png


1584871203004.png
 

Zack Barresse

MrExcel MVP
Joined
Dec 9, 2003
Messages
10,881
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
  2. Mobile
  3. Web
Yes, it's quite possible and has been done for some time now. Read how here.

Your other question would involve a little more code. You would want to:
  • Get a unique list of items from the 'BU' field
  • Iterate the unique list
  • For each item in the list, create new range
  • Run the 'RangetoHTML' on the newly created ranges
 

Watch MrExcel Video

Forum statistics

Threads
1,129,361
Messages
5,635,812
Members
416,884
Latest member
leeshjay

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