Query on declaring 3 separate ranges to be copied onto an email

[4dam5mith]

Hi all,

I am trying to copy data (with determinate columns and indeterminate rows) from 3 sheets on the same worksheet onto an email.

The issue I am having is the declaration of range for the 3 separate sheets, sheet A will always have columns A1 to J1, sheet C and sheet R will always have columns A1 to I1, whereas for all 3 sheets the rows may vary on a daily basis - please refer to the below for a snippet of the code:

Dim arng As Range
Dim crng As Range
Dim rrng As Range

Set arng = Worksheets("A").Range("$A$1:$J$1" & Cells(Rows.Count, "A").End(xlUp).Row)
Set crng = Worksheets("C").Range("$A$1:$I$1" & Cells(Rows.Count, "A").End(xlUp).Row)
Set rrng = Worksheets("R").Range("$A$1:$I$1" & Cells(Rows.Count, "A").End(xlUp).Row)

For the above:

• Inclusive of the header on the top row; Sheet A has data from A1 to J6, however it copies the table from A1 to J12
• Inclusive of the header on the top row; Sheet C has data from A1 to I2, however it copies the table from A1 to I12
• Inclusive of the header on the top row; Sheet R has data from A1 to I16, however it copies the table from A1 to I13

Can I check if there is a better way of selecting all the cells on each respective worksheet, or whether there is a workaround on my code so that it selects and copies all the data within each worksheet - not more and not less?

Thanks

 

[4dam5mith]

Please see the below for the full code for your reference

Sub SendUpdateEmail()

Dim outlook As Object
Dim newEmail As Object
Dim EmailTo As String
Dim EmailCC As String
Dim UpdateDate As String
Dim strSig As String
Dim arng As Range
Dim crng As Range
Dim rrng As Range



Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)
EmailTo = "test@gmail.com"
EmailCC = "test@gmail.com"
UpdateDate = Format(Date, "YYYY-MM-DD")
Set arng = Worksheets("A").Range("$A$1:$J$1" & Cells(Rows.Count, "A").End(xlUp).Row)
Set crng = Worksheets("C").Range("$A$1:$I$1" & Cells(Rows.Count, "A").End(xlUp).Row)
Set rrng = Worksheets("R").Range("$A$1:$I$1" & Cells(Rows.Count, "A").End(xlUp).Row)

With newEmail
.To = EmailTo
.CC = EmailCC
.BCC = ""
.Subject = "XXXXXXX " + UpdateDate + " YYYYYYYYY"
.Display
strSig = .HTMLBody

.HTMLBody = "Morning Team," & "<br>" & "<br>" & "<b> XXXXXXXXX </b>" + RangetoHTML(arng) & "<br>" & "<br>" & "<b> YYYYYYYY </b>" + RangetoHTML(crng) & "<br>" & "<br>" & "<b> ZZZZZZZ </b>" + RangetoHTML(rrng)

.Display

End With

Set newEmail = Nothing
Set outlook = Nothing

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 xublishsource=", _
"align=left xublishsource=")

'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