Selection of a Range from Sheet1 based on an input on Sheet2

StevieMP · May 24, 2024

Hi There,
I have an Excel workbook and I would like to have some VBA code that when executed looks at the information input into tab Sheet2, Column E, Row 7, Cell E7:

Sheet2

A

B

C

D

E

F

G

H

I

J

K

L

M

N

Header1

Header2

Header3

Header4

Header5

Header6

Header7

Header8

Header9

Header10

Header11

Header12

Header13

Header14

data1

INFO

Here marked as "INFO", and then based on what is entered, selects a named range called "Information1" in tab Sheet1 to copy and paste the range into an email and then loops to the next empty line and stops once completed.

Then, if the next line in Sheet2, Column E, Row 8, Cell E8 has on the next execution INFO3 input, the code selects the next named range in tab Sheet1 called "Information3"

Sheet1

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Thank you in advance.
Steve

mumps · May 24, 2024

Are "INFO" and "INFO3" the actual text you will be entering in column E and are "Information1" and "Information3" the actual names for the named ranges? If not, please post the actual text and corresponding names you are using. Also, a few more examples of text entered and corresponding names would be helpful.

StevieMP · May 24, 2024

mumps said:
Are "INFO" and "INFO3" the actual text you will be entering in column E and are "Information1" and "Information3" the actual names for the named ranges? If not, please post the actual text and corresponding names you are using. Also, a few more examples of text entered and corresponding names would be helpful.

Hi Mumps - Thank you for your response. You've helped me previously! I've sort of lost touch with my vba and just been doing little bits and pieces - and it's as if my brain has gone to mush!!
The text for INFO & INFO3 - the actual inputs are going to be one of either 3 input - LUX, LON, or DUB in column E.

The named ranges (Information1, Information2, Information3) will probably reflect the name of the actual input given in column E, so :
LUX will equate to Information1
LON will equate to Information2
DUB will equate to Information3

In essence the actual text in Information1, 2 & 3 will be an email which I am in the process of working on at the moment.

Hope this helps and thank you in advance.

mumps · May 24, 2024

Let's say that there are 4 occurrences of "LUX" in column E. Would you want to create 4 different emails or would you want to create one email and send it to 4 people?

StevieMP · May 24, 2024

mumps said:
Let's say that there are 4 occurrences of "LUX" in column E. Would you want to create 4 different emails or would you want to create one email and send it to 4 people?

Say today Day 1, LUX is entered first, one email should be created using the Information1 range.
Following day, Day 2 on the next line DUB is entered, and therefore one email should be created using the Information3 range. The first line with LUX is now history so nothing more is to be done and so on.
Day 3 LON is entered on the next line and Information2 range email is to be used.
Day 4 LUX is entered again and Information1 range used for a new email.

So when a line is created, one new email is created at that point in time. If there are 10 lines after 10 days an email is created after every increment. Not 10 emails all at once.

mumps · May 24, 2024

Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your Sheet2 and click 'View Code'. Paste the code into the empty code window that opens up. Close the code window to return to your sheet. Enter a value in column E and press the ENTER key. The email will be created. Please note that the code doesn't used named ranges but rather a direct reference to the appropriate range in Sheet1.

VBA Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Column <> 5 Then Exit Sub
    Application.ScreenUpdating = False
    Dim rng As Range, lRow As Long, srcWS As Worksheet, OutApp As Object, OutMail As Object
    Set srcWS = Sheets("Sheet1")
    lRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set OutApp = CreateObject("Outlook.Application")
    Select Case Target.Value
        Case "LUX"
            Set rng = srcWS.Range("A5:E" & lRow)
        Case "LON"
            Set rng = srcWS.Range("H5:L" & lRow)
        Case "DUB"
            Set rng = srcWS.Range("O5:S" & lRow)
    End Select
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = ""
        .Subject = ""
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(rng As Range)
    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"
    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
    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
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

StevieMP · May 28, 2024

mumps said:

Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your Sheet2 and click 'View Code'. Paste the code into the empty code window that opens up. Close the code window to return to your sheet. Enter a value in column E and press the ENTER key. The email will be created. Please note that the code doesn't used named ranges but rather a direct reference to the appropriate range in Sheet1.

VBA Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Column <> 5 Then Exit Sub
    Application.ScreenUpdating = False
    Dim rng As Range, lRow As Long, srcWS As Worksheet, OutApp As Object, OutMail As Object
    Set srcWS = Sheets("Sheet1")
    lRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set OutApp = CreateObject("Outlook.Application")
    Select Case Target.Value
        Case "LUX"
            Set rng = srcWS.Range("A5:E" & lRow)
        Case "LON"
            Set rng = srcWS.Range("H5:L" & lRow)
        Case "DUB"
            Set rng = srcWS.Range("O5:S" & lRow)
    End Select
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = ""
        .Subject = ""
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(rng As Range)
    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"
    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
    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
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Morning Mumps,
Thank you for the code....I've copied all the code and put the code into a worksheet module.
I have typed LUX into the cell in Sheet2 where the word INFO is, pressed enter .....no email is generated.
I know this is a silly question - I can't step through the code, how can I step through it to see what it's doing?

mumps · May 28, 2024

I tested the macro using the data you posted and it worked correctly. Unfortunately, a macro that works with sample data most often won't work with your actual data. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not pictures) of your actual two sheets (de-sensitized if necessary). Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here.

StevieMP · May 28, 2024

mumps said:
I tested the macro using the data you posted and it worked correctly. Unfortunately, a macro that works with sample data most often won't work with your actual data. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not pictures) of your actual two sheets (de-sensitized if necessary). Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here.

Hi Mumps,
I am trying to upload the file, however I cannot see the XL2BB add-in, in the menu to attach.

Slight update is - on Sheet1, if LUX, LON or DUB is typed into the cell E just under Cust, then in Sheet3 an email is created based off the following data which will be in the columns with inputs in criteria
LUX = Information1
LON = Information2
DUB = Information3

If possible, when the email is created, can it use the Email addresses that are listed on Sheet2 depending on what the input is of LUX, LON or DUB
So :
LUX = Emails addresses in columns A & B
LON = Emails addresses in columns F & G
DUB = Emails addresses in columns K & L

Sheet1

Identifier - Name	Identifier	New/Amend	Code	Cust
Test			Test	LUX

Sheet2

SS LUX Email List

Email CC:

Subject Heading

File Attachments

SS LON Email List

Email CC:

Subject Heading

File Attachments

SS DUB Email List

Email CC:

Subject Heading

File Attachments

Email Address

Sheet3

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information 1

Information 2

Information 3

Information

Then when a new line is used the process starts all over again.

mumps · May 28, 2024

This worked for me (in the worksheet code module) using the data you posted. If it doesn't work for you, upload your file to dropbox.com or box.com and post the link here.

VBA Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Column <> 5 Then Exit Sub
    Application.ScreenUpdating = False
    Dim rng As Range, lRow As Long, srcWS As Worksheet, addrWS As Worksheet, OutApp As Object, OutMail As Object
    Set srcWS = Sheets("Sheet3")
    Set addrWS = Sheets("Sheet2")
    lRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set OutApp = CreateObject("Outlook.Application")
    Select Case Target.Value
        Case "LUX"
            Set rng = srcWS.Range("A5:E" & lRow)
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = Join(Application.WorksheetFunction.Transpose(addrWS.Range("A2", addrWS.Range("A" & Rows.Count).End(xlUp)).Value), ";")
                .cc = Join(Application.WorksheetFunction.Transpose(addrWS.Range("B2", addrWS.Range("B" & Rows.Count).End(xlUp)).Value), ";")
                .Subject = ""
                .HTMLBody = RangetoHTML(rng)
                .Display
            End With
        Case "LON"
            Set rng = srcWS.Range("H5:L" & lRow)
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = Join(Application.WorksheetFunction.Transpose(addrWS.Range("F2", addrWS.Range("F" & Rows.Count).End(xlUp)).Value), ";")
                .cc = Join(Application.WorksheetFunction.Transpose(addrWS.Range("G2", addrWS.Range("G" & Rows.Count).End(xlUp)).Value), ";")
                .Subject = ""
                .HTMLBody = RangetoHTML(rng)
                .Display
            End With
        Case "DUB"
            Set rng = srcWS.Range("O5:S" & lRow)
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = Join(Application.WorksheetFunction.Transpose(addrWS.Range("K2", addrWS.Range("K" & Rows.Count).End(xlUp)).Value), ";")
                .cc = Join(Application.WorksheetFunction.Transpose(addrWS.Range("L2", addrWS.Range("L" & Rows.Count).End(xlUp)).Value), ";")
                .Subject = ""
                .HTMLBody = RangetoHTML(rng)
                .Display
            End With
    End Select
    Application.ScreenUpdating = True
End Sub

Selection of a Range from Sheet1 based on an input on Sheet2

StevieMP

Board Regular

Excel Facts

mumps

Well-known Member

StevieMP

Board Regular

mumps

Well-known Member

StevieMP

Board Regular

mumps

Well-known Member

StevieMP

Board Regular

mumps

Well-known Member

StevieMP

Board Regular

mumps

Well-known Member

Similar threads

Forum statistics

Share this page

Selection of a Range from Sheet1 based on an input on Sheet2

Board Regular

Excel Facts

Well-known Member

Board Regular

Well-known Member

Board Regular

Well-known Member

Board Regular

Well-known Member

Board Regular

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock