justanokayengineer
New Member
- Joined
- Jan 10, 2022
- Messages
- 3
- Office Version
- 365
- Platform
- Windows
I have a macro that creates an Outlook email with a table containing data from selected ranges in Excel. However, it does not work for non-contiguous ranges. When user manually types comma or holds CTRL to select multiple ranges, it only grabs the first set of continuous range. How can I make it so the user can select multiple, separate ranges?
Here is my working code:
Here is my working code:
VBA Code:
Sub Send_Email()
Dim xRg As Range
Dim I, J As Long
Dim xAddress As String
Dim xEmailBody As String
Dim xMailOut As Outlook.MailItem
Dim xOutApp As Outlook.Application
Dim dtToday As Date
dtToday = Format(Date, "YYYY/MM/DD")
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select range you need to paste into email body", "KuTools For Excel", xAddress, , , , , 8)
xEmailBody = "<table><table border=1><th>CR</th><th>Assign Date</th><th>Due Date</th><th>Program</th><th>MDE Notes</th><th>DMC</th>"
If xRg Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xOutApp = CreateObject("Outlook.Application")
Set xMailOut = xOutApp.CreateItem(olMailItem)
For I = 1 To xRg.Rows.Count
xEmailBody = xEmailBody & "<tr>"
For J = 1 To xRg.Columns.Count
xEmailBody = xEmailBody & "<td>" & xRg.Cells(I, J).Value & "</td>"
Next
xEmailBody = xEmailBody & "</tr>"
Next
xEmailBody = "Hi, <br><br>text text text<br><br>" & xEmailBody & "</table>" & "<br>Best,<br><br>"
With xMailOut
.To = Application.InputBox(Prompt:="Select To email", Type:=8)
.Subject = "email subject text " & dtToday
.HTMLBody = xEmailBody
.Display
End With
Set xMailOut = Nothing
Set xOutApp = Nothing
Application.ScreenUpdating = True
End Sub