How to Embed Excel range into Outlook email using VBA code

Hi, I'm sending an email to multiple users and trying to add to the code I already have to send to specific users. This code works but I also need to embed the attached range for the specific person to embed in the body of the email. Please assist. Here is the existing code:

Sub Mail_POPending()

Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object
Dim strRptHeading As String
Dim strCell As String
Dim intRowStart, intRowEnd As Integer
Dim strMgrID, strRepID, strRepName, strNextRepID As String
Dim strMsg, strCR, strCR2 As String
Dim strRep As String


Application.ScreenUpdating = False


With Application
.ScreenUpdating = False
.EnableEvents = False
End With


Set Source = Nothing
On Error Resume Next

' Initialize variable with carriage returns
strCR = Chr(13) & Chr(10) 'equivalent to one Enter
strCR2 = Chr(13) & Chr(10) & Chr(13) & Chr(10) 'equivalent to hitting Enter twice




' Set title and heading section to be emailed with every report
strRptHeading = "E1:M1"

' Initialize variables to start searching for report range
intRowStart = 2
intRowEnd = 2


' Loop to mail report until no data is found
Do Until Range("A" & intRowStart) = ""

' Set next rep to process
strRepID = Range("B" & intRowStart)
strRepName = Range("E" & intRowStart)
strRep = strRepName

' String together message body
strMsg = strRepName & "," & strCR2 _
& "You are receiving this report as you currently have some closed accounts receiving phased out product. The optimization team is looking to close out the optimization process in January." & strCR2 _
& "To expedite the process, we are tracking the revenue monthly and request the curbing of sales for the product. Please provide explanation for the over rides:" & strCR2 _
& " 1. Is the revenue something we are to continue to experience?" & strCR _
& " 2. What do we expect to see in the months leading to the cut off of January?:" & strCR _
& " a. Respond by indicating in the comments section highlighted in yellow" & strCR _
& " b. Order Number (as shown on the attached)" & strCR _
& " c. Short reason why we should consider the account as a risk if it is" & strCR2 _
& "We are looking forward to partner with your team. Thank you." & strCR2 _
& "Regards," & strCR _
& "John " & strCR _
& " Analyst | U.S. Peripheral" & strCR2 _
& "Medtronic" & strCR _
& " | Atlanta, GA 30339 | USA" & strCR _
& " " & strCR _
& "medtronic.com" & strCR _
& "LET'S TAKE HEALTHCARE" & strCR _
& "FURTHER, TOGETHER"


' Loop though cells to determine range for next report/mailing
' This looks at the RepID and will compile all rows with the same RepID - data needs to be sorted and in order
Do
intRowEnd = intRowEnd + 1
strNextRepID = Range("B" & intRowEnd)
Loop Until strRepID <> strNextRepID
intRowEnd = intRowEnd - 1

' Set manager ID for email (optional)
strMgrID = Range("A" & intRowEnd)


'Columns should match what your strRptHeading columns are
Set Source = Range(strRptHeading & ",E" & intRowStart & ":M" & intRowEnd).SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
Exit Sub
End If

Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)

Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With

TempFilePath = Environ$("temp") & ""
'Use the name you want the attached file to have
TempFileName = "Wrong Way Revenue"

FileExtStr = ".xlsx": FileFormatNum = 51

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

With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.SentOnBehalfOfName = "john.g.wambaa@medtronic.com"
.To = strRepID 'add & "@medtronic.com" if using username rather than full email address
.CC = strMgrID '& "@medtronic.com" ''optional
.BCC = "John.g.wambaa@medtronic.com" ''optional
.Subject = "Please Review: At Risk Wrong Way Revenue" & " " & strRep
.Body = strMsg
.Attachments.Add Dest.FullName
.Display ' or use .Send
End With
On Error GoTo 0
.Close savechanges:=False
End With

' remove temporary file
Kill TempFilePath & TempFileName & FileExtStr

' Reser variables
Set OutMail = Nothing
Set OutApp = Nothing


' Position variables for next rep
intRowStart = intRowEnd + 1
intRowEnd = intRowStart


Loop


With Application
.ScreenUpdating = True
.EnableEvents = True
End With

Application.ScreenUpdating = True

End Sub

Welcome to the forum!

Please paste code between code tags. Click the Go Advanced in lower right of a reply box, and then the # icon on the toolbar or type the tags.

The two methods would be copy and paste using the WordEditor method. The 2nd is to convert the range to html. For that method, see: https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

How to embed excel table into outlook

Thanks Kenneth for your welcome. I hope you meant me putting the code here. It was provided for me and I adjusted it but need the embedded table. I saw your link too. How do I incorporate the solution given by bruins into this code.

Sub Mail_POPending()

Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object
Dim strRptHeading As String
Dim strCell As String
Dim intRowStart, intRowEnd As Integer
Dim strMgrID, strRepID, strRepName, strNextRepID As String
Dim strMsg, strCR, strCR2 As String
Dim strRep As String


Application.ScreenUpdating = False


With Application
.ScreenUpdating = False
.EnableEvents = False
End With


Set Source = Nothing
On Error Resume Next

' Initialize variable with carriage returns
strCR = Chr(13) & Chr(10) 'equivalent to one Enter
strCR2 = Chr(13) & Chr(10) & Chr(13) & Chr(10) 'equivalent to hitting Enter twice




' Set title and heading section to be emailed with every report
strRptHeading = "E1:M1"

' Initialize variables to start searching for report range
intRowStart = 2
intRowEnd = 2


' Loop to mail report until no data is found
Do Until Range("A" & intRowStart) = ""

' Set next rep to process
strRepID = Range("B" & intRowStart)
strRepName = Range("E" & intRowStart)
strRep = strRepName

' String together message body
strMsg = strRepName & "," & strCR2 _
& "You are receiving this report as you currently have some closed accounts receiving phased out product. The optimization team is looking to close out the optimization process in January." & strCR2 _
& "To expedite the process, we are tracking the revenue monthly and request the curbing of sales for the product. Please provide explanation for the over rides:" & strCR2 _
& " 1. Is the revenue something we are to continue to experience?" & strCR _
& " 2. What do we expect to see in the months leading to the cut off of January?:" & strCR _
& " a. Respond by indicating in the comments section highlighted in yellow" & strCR _
& " b. Order Number (as shown on the attached)" & strCR _
& " c. Short reason why we should consider the account as a risk if it is" & strCR2 _
& "We are looking forward to partner with your team. Thank you." & strCR2 _
& "Regards," & strCR _
& "John " & strCR _
& " Analyst | " & strCR2 _
& "" & strCR _
& "3225 ., Suite 500 | Atlanta, GA 30339 | USA" & strCR _
& "Mobile " & strCR _
& "john " & strCR _
& "medtronic.com" & strCR _
& "LET'S TAKE HEALTHCARE" & strCR _
& "FURTHER, TOGETHER"


' Loop though cells to determine range for next report/mailing
' This looks at the RepID and will compile all rows with the same RepID - data needs to be sorted and in order
Do
intRowEnd = intRowEnd + 1
strNextRepID = Range("B" & intRowEnd)
Loop Until strRepID <> strNextRepID
intRowEnd = intRowEnd - 1

' Set manager ID for email (optional)
strMgrID = Range("A" & intRowEnd)


'Columns should match what your strRptHeading columns are
Set Source = Range(strRptHeading & ",E" & intRowStart & ":M" & intRowEnd).SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
Exit Sub
End If

Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)

Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With

TempFilePath = Environ$("temp") & ""
'Use the name you want the attached file to have
TempFileName = "Wrong Way Revenue"

FileExtStr = ".xlsx": FileFormatNum = 51

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

With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.SentOnBehalfOfName = "email"
.To = strRepID 'add & "@" if using username rather than full email address
.CC = strMgrID '& "@medtronic.com" ''optional
.BCC = "" ''optional
.Subject = "Please Review: At Risk Wrong Way Revenue" & " " & strRep
.Body = strMsg
.Attachments.Add Dest.FullName
.Display ' or use .Send
End With
On Error GoTo 0
.Close savechanges:=False
End With

' remove temporary file
Kill TempFilePath & TempFileName & FileExtStr

' Reser variables
Set OutMail = Nothing
Set OutApp = Nothing


' Position variables for next rep
intRowStart = intRowEnd + 1
intRowEnd = intRowStart


Loop


With Application
.ScreenUpdating = True
.EnableEvents = True
End With

Application.ScreenUpdating = True

End Sub

How to embed excel table into outlook

Thanks Kenneth for your welcome. I hope you meant me putting the code here. It was provided for me and I adjusted it but need the embedded table. I saw your link too. How do I incorporate the solution given by bruins into this code.

Sub Mail_POPending()

Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object
Dim strRptHeading As String
Dim strCell As String
Dim intRowStart, intRowEnd As Integer
Dim strMgrID, strRepID, strRepName, strNextRepID As String
Dim strMsg, strCR, strCR2 As String
Dim strRep As String


Application.ScreenUpdating = False


With Application
.ScreenUpdating = False
.EnableEvents = False
End With


Set Source = Nothing
On Error Resume Next

' Initialize variable with carriage returns
strCR = Chr(13) & Chr(10) 'equivalent to one Enter
strCR2 = Chr(13) & Chr(10) & Chr(13) & Chr(10) 'equivalent to hitting Enter twice




' Set title and heading section to be emailed with every report
strRptHeading = "E1:M1"

' Initialize variables to start searching for report range
intRowStart = 2
intRowEnd = 2


' Loop to mail report until no data is found
Do Until Range("A" & intRowStart) = ""

' Set next rep to process
strRepID = Range("B" & intRowStart)
strRepName = Range("E" & intRowStart)
strRep = strRepName

' String together message body
strMsg = strRepName & "," & strCR2 _
& "You are receiving this report as you currently have some closed accounts receiving phased out product. The optimization team is looking to close out the optimization process in January." & strCR2 _
& "To expedite the process, we are tracking the revenue monthly and request the curbing of sales for the product. Please provide explanation for the over rides:" & strCR2 _
& " 1. Is the revenue something we are to continue to experience?" & strCR _
& " 2. What do we expect to see in the months leading to the cut off of January?:" & strCR _
& " a. Respond by indicating in the comments section highlighted in yellow" & strCR _
& " b. Order Number (as shown on the attached)" & strCR _
& " c. Short reason why we should consider the account as a risk if it is" & strCR2 _
& "We are looking forward to partner with your team. Thank you." & strCR2 _
& "Regards," & strCR _
& "John " & strCR _
& " Analyst | " & strCR2 _
& "" & strCR _
& "3225 ., Suite 500 | Atlanta, GA 30339 | USA" & strCR _
& "Mobile " & strCR _
& "john " & strCR _
& "medtronic.com" & strCR _
& "LET'S TAKE HEALTHCARE" & strCR _
& "FURTHER, TOGETHER"


' Loop though cells to determine range for next report/mailing
' This looks at the RepID and will compile all rows with the same RepID - data needs to be sorted and in order
Do
intRowEnd = intRowEnd + 1
strNextRepID = Range("B" & intRowEnd)
Loop Until strRepID <> strNextRepID
intRowEnd = intRowEnd - 1

' Set manager ID for email (optional)
strMgrID = Range("A" & intRowEnd)


'Columns should match what your strRptHeading columns are
Set Source = Range(strRptHeading & ",E" & intRowStart & ":M" & intRowEnd).SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
Exit Sub
End If

Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)

Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With

TempFilePath = Environ$("temp") & ""
'Use the name you want the attached file to have
TempFileName = "Wrong Way Revenue"

FileExtStr = ".xlsx": FileFormatNum = 51

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

With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.SentOnBehalfOfName = "email"
.To = strRepID 'add & "@" if using username rather than full email address
.CC = strMgrID '& "@medtronic.com" ''optional
.BCC = "" ''optional
.Subject = "Please Review: At Risk Wrong Way Revenue" & " " & strRep
.Body = strMsg
.Attachments.Add Dest.FullName
.Display ' or use .Send
End With
On Error GoTo 0
.Close savechanges:=False
End With

' remove temporary file
Kill TempFilePath & TempFileName & FileExtStr

' Reser variables
Set OutMail = Nothing
Set OutApp = Nothing


' Position variables for next rep
intRowStart = intRowEnd + 1
intRowEnd = intRowStart


Loop


With Application
.ScreenUpdating = True
.EnableEvents = True
End With

Application.ScreenUpdating = True

End Sub

It makes it tough to read code and modify when not in code tags. I would hope that you are using structure, indents.

If clicking the # was not understood, just type the tags. e.g. (code)your code pasted here(/code) but replace ()'s with []'s.

I guess you want to both attach the file and embed the usedrange in the added workbook?
1. Copy the RangeToHTML() routine from Ron's site.
2. After the last PaseSpecial, set the value of a string variable to the result of (1) with the ActiveSheet.UsedRange as the input. Or do in (3).
3. Concatenate your current body string to the string from (2).
4. Replace .Body with .HTMLbody.

Example for (2)-(4):

Thanks for your assistance. This is difficult for me because I don't quite understand all the code nuances and I'm just using what someone provided me to send emails. I don't know whether the entire code should be converted to HTML or where to insert the range you quote above..

In post #2, I explained one method that uses Ron's RangeToHTML(). Copy it from the link that I gave you in post #2 and put it in a Module as I explained in post #5.

In post #5, I showed you how to call/use RangeToHTML() and where to put it in your code. Again, find the line:
and add the line below it:

Comment out the line of code with .BODY, and replace it with the .HTMLBODY line as shown in post #5.