If you would like to post, please check out the MrExcel Message Board FAQ and register here. If you forgot your password, you can reset your password.

Input box with non contiguous range in VBA not working

J

justanokayengineer

New Member

Jan 10, 2022

#1

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

Which lookup functions find a value equal or greater than the lookup value?

Click here to reveal answer

MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.

Sort by date Sort by votes

Eric W

MrExcel MVP

Jan 10, 2022

#2

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

KOKOSEK

Well-known Member

Jan 10, 2022

#3

Example data:

Book1

C

D

E

F

G

H

I

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

Sheet1

Cell Formulas
Range	Formula
C2:E21,G2:I21	C2	=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:

Upvote 0

J

justanokayengineer

New Member

Jan 10, 2022

#4

Eric W said:

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

J

justanokayengineer

New Member

Jan 10, 2022

#5

KOKOSEK said:
Example data:

Book1
C D E F G H I
2 $C$2 $D$2 $E$2 $G$2 $H$2 $I$2
3 $C$3 $D$3 $E$3 $G$3 $H$3 $I$3
4 $C$4 $D$4 $E$4 $G$4 $H$4 $I$4
5 $C$5 $D$5 $E$5 $G$5 $H$5 $I$5
6 $C$6 $D$6 $E$6 $G$6 $H$6 $I$6
7 $C$7 $D$7 $E$7 $G$7 $H$7 $I$7
8 $C$8 $D$8 $E$8 $G$8 $H$8 $I$8
9 $C$9 $D$9 $E$9 $G$9 $H$9 $I$9
10 $C$10 $D$10 $E$10 $G$10 $H$10 $I$10
11 $C$11 $D$11 $E$11 $G$11 $H$11 $I$11
12 $C$12 $D$12 $E$12 $G$12 $H$12 $I$12
13 $C$13 $D$13 $E$13 $G$13 $H$13 $I$13
14 $C$14 $D$14 $E$14 $G$14 $H$14 $I$14
15 $C$15 $D$15 $E$15 $G$15 $H$15 $I$15
16 $C$16 $D$16 $E$16 $G$16 $H$16 $I$16
17 $C$17 $D$17 $E$17 $G$17 $H$17 $I$17
18 $C$18 $D$18 $E$18 $G$18 $H$18 $I$18
19 $C$19 $D$19 $E$19 $G$19 $H$19 $I$19
20 $C$20 $D$20 $E$20 $G$20 $H$20 $I$20
21 $C$21 $D$21 $E$21 $G$21 $H$21 $I$21
Sheet1
Cell Formulas
Range Formula
C2:E21,G2:I21 C2 =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

Eric W

MrExcel MVP

Jan 10, 2022

#6

Glad we could help! Thanks for the feedback.

Upvote 0

You must log in or register to reply here.

Similar threads

D

Question

Copying from Excel to Outlook - what am I doing wrong?

Replies: 1

Views: 3K

Dec 4, 2021

John_w

J

P

Question

putting a snippet of code from one to another somehow

Replies: 5

Views: 322

Jul 2, 2024

Patriot2879

P

R

Question

Adding Email Signature to current VBA Code

Replies: 3

Views: 495

Jan 24, 2024

John_w

J

H

Solved

Macro to extract text to Body in Email and Table at end of Body

Replies: 1

Views: 630

May 1, 2024

howard

H

D

Question

VBA to Create Outlook Email Not Working for All Users

Replies: 9

Views: 364

Aug 27, 2024

Logit

Share:

Facebook X (Twitter) LinkedIn Reddit Tumblr WhatsApp Email Link

Forum statistics

Threads: 1,224,823

Messages: 6,181,176

Members: 453,021

Latest member: Justyna P

Share this page

Facebook X (Twitter) LinkedIn Reddit Tumblr WhatsApp Email Link

Top