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

S

StevieMP

Board Regular
Joined
Sep 28, 2021
Messages
73
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
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
 
Upvote 0

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
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
Click to expand...
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
 
Upvote 0
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?
 
Upvote 0
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?
Click to expand...
Hi Mumps,

Will do in a short while. The xx:xx was just a representation of time
 
Upvote 0
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?
Click to expand...
StevieMP said:
Hi Mumps,

Will do in a short while. The xx:xx was just a representation of time
Click to expand...
Hi Mumps,

We had this already:

ABCDEFGHIJKLMN
Header1Header2Header3Header4Header5Header6Header7Header8Header9Header10Header11Header12Header13Header14
data1INFO19/06/2024 & timeBBL

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.
 
Upvote 0
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
 
Upvote 0
Solution
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
Click to expand...
Thank you very much Mumps.....that works exactly.
I've also learnt a lot more.
A very big Thank you.
 
Upvote 0
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.
 
Upvote 0
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
Click to expand...

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
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
Tab Selection from Userform based on Date range
Replies
5
Views
161
campbell1093
C
K
  • Solved
Code to search job id from multiple sources and update main spreadsheet.
2
Replies
10
Views
681
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
324
Peter_SSs
Peter_SSs
F
  • Question Question
How to get optionbutton values from two different groups
Replies
2
Views
569
NoSparks
N
K
  • Question Question
I was try to load data To List Box And Transfer data to Sheet2.... (Not work this userform)
Replies
4
Views
239
krunal123
K

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

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