Input box with non contiguous range in VBA not working

justanokayengineer

New Member
Joined
Jan 10, 2022
Messages
3
Office Version
  1. 365
Platform
  1. 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:
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
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Welcome to the MrExcel forum!

Change:

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

to:

VBA Code:
    For A = 1 To xRg.Areas.Count
        For I = 1 To xRg.Areas(A).Rows.Count
            xEmailBody = xEmailBody & "<tr>"
            For J = 1 To xRg.Areas(A).Columns.Count
                xEmailBody = xEmailBody & "<td>" & xRg.Areas(A).Cells(I, J).Value & "</td>"
            Next J
            xEmailBody = xEmailBody & "</tr>"
        Next I
    Next A
 
Upvote 0
Example data:

Cell Formulas
RangeFormula
C2:E21,G2:I21C2=ADDRESS(ROW(),COLUMN())


with this:

VBA Code:
Sub Send_Email()
    Dim V As Variant
    Dim xRg As Range
    Dim I, J As Long
    Dim xAddress As String
    Dim xEmailBody As String
    Dim xMailOut As Object
    Dim xOutApp As Object
    Dim dtToday As Date: dtToday = Format(Date, "YYYY/MM/DD")
    
    On Error Resume Next
    Set xRg = Application.InputBox("Please select range you need to paste into email body", "KuTools For Excel", "", , , , , 8)
    xEmailBody = "<table border=1><tr><td>CR</td><td>Assign Date</td><td>Due Date</td><td>Program</td><td>MDE Notes</td><td>DMC</td></tr>"
    Application.ScreenUpdating = False
    If xRg Is Nothing Then Exit Sub
    V = Split(xRg.Address, ",")
    Set xRg1 = Range(V(0))
    Set xRg2 = Range(V(1))
    Set xRg = Union(xRg1, xRg2)
    For I = 1 To Application.WorksheetFunction.Max(xRg1.Rows.Count, xRg2.Rows.Count)
        xEmailBody = xEmailBody & "<tr>"
        For J = 1 To (xRg1.Columns.Count + xRg2.Columns.Count) + 1
           If xRg.Cells(I, J).Value <> "" Then xEmailBody = xEmailBody & "<td>" & xRg.Cells(I, J).Value & "</td>"
        Next
        xEmailBody = xEmailBody & "</tr>"
    Next I
    xEmailBody = xEmailBody & "</table>"
    
    xEmailBody = "Hi, <br><br>text text text<br><br>" & xEmailBody & "</table>" & "<br>Best,<br><br>"
    Set xOutApp = CreateObject("Outlook.Application")
    Set xMailOut = xOutApp.CreateItem(olMailItem)
    With xMailOut
        .To = "blahblah@toto.com"
        .Subject = "email subject text " & dtToday
        .HTMLBody = xEmailBody
        .Display
    End With
    Set xMailOut = Nothing
    Set xOutApp = Nothing
    Application.ScreenUpdating = True
End Sub

gives this:

1641830602408.png
 
Upvote 0
Welcome to the MrExcel forum!

Change:

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

to:

VBA Code:
    For A = 1 To xRg.Areas.Count
        For I = 1 To xRg.Areas(A).Rows.Count
            xEmailBody = xEmailBody & "<tr>"
            For J = 1 To xRg.Areas(A).Columns.Count
                xEmailBody = xEmailBody & "<td>" & xRg.Areas(A).Cells(I, J).Value & "</td>"
            Next J
            xEmailBody = xEmailBody & "</tr>"
        Next I
    Next A
this was extremely helpful, thank you so much! very interesting to see Areas.Count
 
Upvote 0
Example data:

Cell Formulas
RangeFormula
C2:E21,G2:I21C2=ADDRESS(ROW(),COLUMN())


with this:

VBA Code:
Sub Send_Email()
    Dim V As Variant
    Dim xRg As Range
    Dim I, J As Long
    Dim xAddress As String
    Dim xEmailBody As String
    Dim xMailOut As Object
    Dim xOutApp As Object
    Dim dtToday As Date: dtToday = Format(Date, "YYYY/MM/DD")
   
    On Error Resume Next
    Set xRg = Application.InputBox("Please select range you need to paste into email body", "KuTools For Excel", "", , , , , 8)
    xEmailBody = "<table border=1><tr><td>CR</td><td>Assign Date</td><td>Due Date</td><td>Program</td><td>MDE Notes</td><td>DMC</td></tr>"
    Application.ScreenUpdating = False
    If xRg Is Nothing Then Exit Sub
    V = Split(xRg.Address, ",")
    Set xRg1 = Range(V(0))
    Set xRg2 = Range(V(1))
    Set xRg = Union(xRg1, xRg2)
    For I = 1 To Application.WorksheetFunction.Max(xRg1.Rows.Count, xRg2.Rows.Count)
        xEmailBody = xEmailBody & "<tr>"
        For J = 1 To (xRg1.Columns.Count + xRg2.Columns.Count) + 1
           If xRg.Cells(I, J).Value <> "" Then xEmailBody = xEmailBody & "<td>" & xRg.Cells(I, J).Value & "</td>"
        Next
        xEmailBody = xEmailBody & "</tr>"
    Next I
    xEmailBody = xEmailBody & "</table>"
   
    xEmailBody = "Hi, <br><br>text text text<br><br>" & xEmailBody & "</table>" & "<br>Best,<br><br>"
    Set xOutApp = CreateObject("Outlook.Application")
    Set xMailOut = xOutApp.CreateItem(olMailItem)
    With xMailOut
        .To = "blahblah@toto.com"
        .Subject = "email subject text " & dtToday
        .HTMLBody = xEmailBody
        .Display
    End With
    Set xMailOut = Nothing
    Set xOutApp = Nothing
    Application.ScreenUpdating = True
End Sub

gives this:

View attachment 54910
thanks for your reply!
 
Upvote 0

Forum statistics

Threads
1,223,246
Messages
6,170,996
Members
452,373
Latest member
TimReeks

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