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

S

StevieMP

Board Regular
Joined
Sep 28, 2021
Messages
70
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
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
ABCDEFGHIJKLMN
Header1Header2Header3Header4Header5Header6Header7Header8Header9Header10Header11Header12Header13Header14
data1INFO

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
ABCDEFGHIJKLMNOPQRS
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3

Thank you in advance.
Steve
 
Sort by date Sort by votes
mumps said:
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
Click to expand...
Thank you Mumps - I still can't get the code to work. I have tried to access dropbox and box but from my work they are blocked. I will try to upload on my pc at home.
Will the code work if I put it in the normal module instead of a worksheet module?
 
Upvote 0

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
This is a change event code which means that it is triggered by a change in the worksheet so it must go into the code module for that worksheet.
Click here to download your file and give it a try.
 
Upvote 0
mumps said:
This is a change event code which means that it is triggered by a change in the worksheet so it must go into the code module for that worksheet.
Click here to download your file and give it a try.
Click to expand...
Hi Mumps - I finally got it working! I pasted the code into the wrong tab. Thank you for help on that. I've certainly learnt something new with Change Event Code.
The code creates the email exactly how I wanted it - How can I reference the
.Subject = ""

...with actual text based on an input on Sheet2, column C, cell C2
e.g.
Column A Column B Column C
SS LUX Email ListEmail CC:Subject Heading
EmailEmail??
 
Upvote 0
Try:
VBA Code: 
Option Compare Text
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 = Join(Application.WorksheetFunction.Transpose(addrWS.Range("C2", addrWS.Range("C" & Rows.Count).End(xlUp)).Value), ";")
                .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 = Join(Application.WorksheetFunction.Transpose(addrWS.Range("H2", addrWS.Range("H" & Rows.Count).End(xlUp)).Value), ";")
                .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 = Join(Application.WorksheetFunction.Transpose(addrWS.Range("M2", addrWS.Range("M" & Rows.Count).End(xlUp)).Value), ";")
                .HTMLBody = RangetoHTML(rng)
                .Display
            End With
    End Select
    Application.ScreenUpdating = True
End Sub
'Join(Application.WorksheetFunction.Transpose(Range("A1:A10").Value), Chr$(10))

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
 
Upvote 0
mumps said:
Try:
VBA Code: 
Option Compare Text
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 = Join(Application.WorksheetFunction.Transpose(addrWS.Range("C2", addrWS.Range("C" & Rows.Count).End(xlUp)).Value), ";")
                .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 = Join(Application.WorksheetFunction.Transpose(addrWS.Range("H2", addrWS.Range("H" & Rows.Count).End(xlUp)).Value), ";")
                .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 = Join(Application.WorksheetFunction.Transpose(addrWS.Range("M2", addrWS.Range("M" & Rows.Count).End(xlUp)).Value), ";")
                .HTMLBody = RangetoHTML(rng)
                .Display
            End With
    End Select
    Application.ScreenUpdating = True
End Sub
'Join(Application.WorksheetFunction.Transpose(Range("A1:A10").Value), Chr$(10))

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
Click to expand...

Thanks Mumps - I tried that earlier and the code breaks, even though if I hover over the code, I can see what the subject written in to the code line is:

1717089495274.png


...and the email is not generated.
 
Upvote 0
Can you post a dozen or so rows of data that is more representative of your actual data including the "Subject" data in column C?
 
Upvote 0
mumps said:
Can you post a dozen or so rows of data that is more representative of your actual data including the "Subject" data in column C?
Click to expand...

Hi Mumps,

So on Sheet2 :

Sheet2
Column AColumn BColumn CColumn DColumn EColumn FColumn GColumn HColumn IColumn JColumn KColumn LColumn MColumn N
SS LUX Email ListEmail CC:Subject HeadingFile AttachmentSS LON Email ListEmail CC:Subject HeadingFile AttachmentSS LON Email ListEmail CC:Subject HeadingFile Attachment
EmailEmail??EmailEmail??EmailEmail??

I'm thinking of either having an input in Column C, H or M depending on what the input on Sheet1 is which was the Case LUX, LON or DUB or an input on Sheet3 just above where the Range is set.
e.g.


Sheet3

ABCDEFGHIJKLMNOPQRS
Subject
This will be the subject for the email
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3Information 3
Information 1Information 1Information 1Information 1Information 1Information 2Information 2Information 2Information 2Information 2Information 3Information 3Information 3Information 3
 
Upvote 0
For clarification: the subject will be in cell A1 of Sheet3 for "LUX". Will cells H1 and O1 contain the subject for "LON" AND "DUB" respectively?
 
Upvote 0
mumps said:
For clarification: the subject will be in cell A1 of Sheet3 for "LUX". Will cells H1 and O1 contain the subject for "LON" AND "DUB" respectively?
Click to expand...
Hi Mumps,
For clarification, yes the subject will be in cell A3 of Sheet3 for "LUX", H3 for "LON" and O3 for "DUB".

Also, after the email has been created have you some code that writes a timestamp into the cell next to where I have entered the "LUX", "LON" or "DUB" in Sheet1 ?

ABCDEFGHIJKLMN
Header1Header2Header3Header4Header5Header6Header7Header8Header9Header10Header11Header12Header13Header14
data1LUX or LON or DUBTimestamp here

Thank you.
 
Upvote 0
StevieMP said:
Hi Mumps,
For clarification, yes the subject will be in cell A3 of Sheet3 for "LUX", H3 for "LON" and O3 for "DUB".

Also, after the email has been created have you some code that writes a timestamp into the cell next to where I have entered the "LUX", "LON" or "DUB" in Sheet1 ?

ABCDEFGHIJKLMN
Header1Header2Header3Header4Header5Header6Header7Header8Header9Header10Header11Header12Header13Header14
data1LUX or LON or DUBTimestamp here

Thank you.
Click to expand...
Good Morning Mumps - Just wondered if you were able to work out the "Subject" and the "Timestamp" ?
Thank you
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
Code to search job id from multiple sources and update main spreadsheet.
2
Replies
10
Views
509
mumps
mumps
vinzent
  • Solved
Get the PN from one cell with information if this PN appear in the list in another tab
Replies
3
Views
309
Peter_SSs
Peter_SSs
F
  • Question
How to get optionbutton values from two different groups
Replies
2
Views
516
NoSparks
N
D
  • Solved
Populate a "Despatch Note" from a Separate "Project Tracker" Workbook when a Unique Job Number (UJN) is input.
Replies
5
Views
641
Kerryx
K
A
  • Solved
Retrieve multiple values using VBA from dictionary
Replies
4
Views
1K
ajl344
A

Forum statistics

Threads
1,221,418
Messages
6,159,791
Members
451,589
Latest member
Harold14

Share this page

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