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

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
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
 
Upvote 0
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
 
Upvote 0
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))
 
Upvote 0
Indeed, it was missing sheet reference. The code works now as it should. many thanks for your help!
 
Upvote 0
Glad we could help and thanks for letting us know.
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,496
Messages
6,113,995
Members
448,539
Latest member
alex78

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
Back
Top