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 · Jun 12, 2024

My apologies. I thought that I had posted the revised macro. Here it is:

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 = srcWS.Range("A3")
                .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 = srcWS.Range("H3")
                .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 = srcWS.Range("O3")
                .HTMLBody = RangetoHTML(rng)
                .Display
            End With
    End Select
    Target.Offset(, 1) = Now()
    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 · Jun 19, 2024

mumps said:

My apologies. I thought that I had posted the revised macro. Here it is:

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 = srcWS.Range("A3")
                .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 = srcWS.Range("H3")
                .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 = srcWS.Range("O3")
                .HTMLBody = RangetoHTML(rng)
                .Display
            End With
    End Select
    Target.Offset(, 1) = Now()
    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 - Apologies for not coming back to you, I have been away. That has worked perfectly thank you so very much.

If I wanted to add another case for another column on Sheet2 say column M further along is that easier to add?
So if I type and input in column M the abbreviation "BBL" it generates another email based on information in another sheet (Sheet4) and generates another email?
Then, once the email is created a timestamp is added as an addition to the same cell the abbreviation was added, so BBL dd/mm/yyyy xx:xx

mumps · Jun 19, 2024

Please upload a new file which includes the additional sheets with data. Explain in detail using a few examples from your data. Also, what does the "xx:xx" in "BBL dd/mm/yyyy xx:xx" refer to?

StevieMP · Jun 19, 2024

mumps said:
Please upload a new file which includes the additional sheets with data. Explain in detail using a few examples from your data. Also, what does the "xx:xx" in "BBL dd/mm/yyyy xx:xx" refer to?

Hi Mumps,

Will do in a short while. The xx:xx was just a representation of time

StevieMP · Jun 19, 2024

mumps said:
Please upload a new file which includes the additional sheets with data. Explain in detail using a few examples from your data. Also, what does the "xx:xx" in "BBL dd/mm/yyyy xx:xx" refer to?

StevieMP said:
Hi Mumps,

Will do in a short while. The xx:xx was just a representation of time

Hi Mumps,

We had this already:

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

19/06/2024 & time

BBL

So we have this currently, if either LUX, LON, DUB are entered into E8 an email is created based on information in the next sheet from a range designated from LUX, LON or DUB.

Now I want to go along to column M (Header13). I want to type in here BBL and that looks at Sheet4 for a range A5 to E55, and then refers to Sheet4 where the data is and then generates an email using that data, looking at the emails to use as previously for the LUX, LON & DUB except the email addresses will be further along in column P and Q .

It's exactly the same as before except taking the information from Sheet4.

Then once that has been completed the cell that has BBL is updated with a timestamp added to the BBL.

mumps · Jun 19, 2024

This code assumes that the subject is in cell A3 of Sheet4.

VBA Code:

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("E:E,M:M")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim rng As Range, lRow As Long, srcWS As Worksheet, srcWS2 As Worksheet, addrWS As Worksheet, OutApp As Object, OutMail As Object
    Set srcWS = Sheets("Sheet3")
    Set srcWS2 = Sheets("Sheet4")
    Set addrWS = Sheets("Sheet2")
    lRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set OutApp = CreateObject("Outlook.Application")
    Select Case Target.Column
        Case Is = 5
            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 = srcWS.Range("A3")
                        .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 = srcWS.Range("H3")
                        .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 = srcWS.Range("O3")
                        .HTMLBody = RangetoHTML(rng)
                        .Display
                    End With
            End Select
        Case Is = 13
            Select Case Target.Value
                Case "BBL"
                    Set rng = srcWS2.Range("A5:E" & lRow)
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = Join(Application.WorksheetFunction.Transpose(addrWS.Range("P2", addrWS.Range("P" & Rows.Count).End(xlUp)).Value), ";")
                        .cc = Join(Application.WorksheetFunction.Transpose(addrWS.Range("Q2", addrWS.Range("Q" & Rows.Count).End(xlUp)).Value), ";")
                        .Subject = srcWS2.Range("A3")
                        .HTMLBody = RangetoHTML(rng)
                        .Display
                    End With
            End Select
    End Select
    Target.Offset(, 1) = Now()
    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 · Jun 20, 2024

mumps said:

This code assumes that the subject is in cell A3 of Sheet4.

VBA Code:

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("E:E,M:M")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim rng As Range, lRow As Long, srcWS As Worksheet, srcWS2 As Worksheet, addrWS As Worksheet, OutApp As Object, OutMail As Object
    Set srcWS = Sheets("Sheet3")
    Set srcWS2 = Sheets("Sheet4")
    Set addrWS = Sheets("Sheet2")
    lRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set OutApp = CreateObject("Outlook.Application")
    Select Case Target.Column
        Case Is = 5
            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 = srcWS.Range("A3")
                        .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 = srcWS.Range("H3")
                        .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 = srcWS.Range("O3")
                        .HTMLBody = RangetoHTML(rng)
                        .Display
                    End With
            End Select
        Case Is = 13
            Select Case Target.Value
                Case "BBL"
                    Set rng = srcWS2.Range("A5:E" & lRow)
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = Join(Application.WorksheetFunction.Transpose(addrWS.Range("P2", addrWS.Range("P" & Rows.Count).End(xlUp)).Value), ";")
                        .cc = Join(Application.WorksheetFunction.Transpose(addrWS.Range("Q2", addrWS.Range("Q" & Rows.Count).End(xlUp)).Value), ";")
                        .Subject = srcWS2.Range("A3")
                        .HTMLBody = RangetoHTML(rng)
                        .Display
                    End With
            End Select
    End Select
    Target.Offset(, 1) = Now()
    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

Thank you very much Mumps.....that works exactly.
I've also learnt a lot more.
A very big Thank you.

Joe4 · Jun 20, 2024

StevieMP,
Please Note: In the future, when marking a post as the solution, please mark the post that contains the solution (not your own post acknowledging that some other post was the solution).
When a post is marked as the solution, it is then shown right underneath the original question so people viewing the question can easily see the question and solution in a single quick glance without having to hunt through all the posts.

I have updated this thread for you.

mumps · Jun 20, 2024

You are very welcome.

StevieMP · Jun 20, 2024

mumps said:

This code assumes that the subject is in cell A3 of Sheet4.

VBA Code:

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("E:E,M:M")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim rng As Range, lRow As Long, srcWS As Worksheet, srcWS2 As Worksheet, addrWS As Worksheet, OutApp As Object, OutMail As Object
    Set srcWS = Sheets("Sheet3")
    Set srcWS2 = Sheets("Sheet4")
    Set addrWS = Sheets("Sheet2")
    lRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set OutApp = CreateObject("Outlook.Application")
    Select Case Target.Column
        Case Is = 5
            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 = srcWS.Range("A3")
                        .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 = srcWS.Range("H3")
                        .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 = srcWS.Range("O3")
                        .HTMLBody = RangetoHTML(rng)
                        .Display
                    End With
            End Select
        Case Is = 13
            Select Case Target.Value
                Case "BBL"
                    Set rng = srcWS2.Range("A5:E" & lRow)
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = Join(Application.WorksheetFunction.Transpose(addrWS.Range("P2", addrWS.Range("P" & Rows.Count).End(xlUp)).Value), ";")
                        .cc = Join(Application.WorksheetFunction.Transpose(addrWS.Range("Q2", addrWS.Range("Q" & Rows.Count).End(xlUp)).Value), ";")
                        .Subject = srcWS2.Range("A3")
                        .HTMLBody = RangetoHTML(rng)
                        .Display
                    End With
            End Select
    End Select
    Target.Offset(, 1) = Now()
    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

Mumps,
If I add another "Case" based on another column using the same Sheet4, is it just the following code to amend and add:

So amend
If Intersect(Target, Range("E:E,M:M")) Is Nothing Then Exit Sub

to

If Intersect(Target, Range("E:E,O:O")) Is Nothing Then Exit Sub

and add the following....

Case Is = 15
Select Case Target.Value
Case "JPMC"
Set rng = srcWS2.Range("E7:G" & lRow)
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Join(Application.WorksheetFunction.Transpose(addrWS.Range("U2", addrWS.Range("U" & Rows.Count).End(xlUp)).Value), ";")
.cc = Join(Application.WorksheetFunction.Transpose(addrWS.Range("V2", addrWS.Range("V" & Rows.Count).End(xlUp)).Value), ";")
.Subject = srcWS2.Range("E3")
.HTMLBody = RangetoHTML(rng)
.Display
End With

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

StevieMP

Board Regular

mumps

Well-known Member

Excel Facts

StevieMP

Board Regular

mumps

Well-known Member

StevieMP

Board Regular

StevieMP

Board Regular

mumps

Well-known Member

StevieMP

Board Regular

Joe4

MrExcel MVP, Junior Admin

mumps

Well-known Member

StevieMP

Board Regular

Similar threads

Forum statistics

Share this page

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

Board Regular

Well-known Member

Excel Facts

Board Regular

Well-known Member

Board Regular

Board Regular

Well-known Member

Board Regular

MrExcel MVP, Junior Admin

Well-known Member

Board Regular

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