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
Try:
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,O:O")) 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
        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
            End Select
    End Select
    Target.Offset(, 1) = Now()
    Application.ScreenUpdating = True
End Sub
Please note that the "rng" for columns M and O overlap.
VBA Code: 
Set rng = srcWS2.Range("A5:E" & lRow)
Set rng = srcWS2.Range("E7:G" & lRow)
 
Upvote 0

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
StevieMP said:
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
Click to expand...
Good Morning Mumps,
Please excuse my request - I have added several "Cases" now and it's all working well, however after adding one more "Case" I am getting a
"Run-time error '13':
Type mismatch
on the line of code :

.To = Join(Application.WorksheetFunction.Transpose(addrWS.Range("AJ2", addrWS.Range("AJ" & Rows.Count).End(xlUp)).Value), ";")


The code I have added/updated is :

If Intersect(Target, Range("E:E,H:H,J:J,L:L,M:M,O:O,R:R")) Is Nothing Then Exit Sub
'If Target.Column <> 5 Then Exit Sub
Application.ScreenUpdating = False
Dim rng As Range, lRow As Long, srcWS As Worksheet, srcWS2 As Worksheet, srcWS3 As Worksheet, srcWS4 As Worksheet, srcWS5 As Worksheet, addrWS As Worksheet, OutApp As Object, OutMail As Object

Set srcWS = Sheets("Sheet3")
Set srcWS2 = Sheets("Sheet4")
Set srcWS3 = Sheets("Sheet5")
Set srcWS4 = Sheets("Sheet6")
Set srcWS5 = Sheets("Sheet8")
Set addrWS = Sheets("Sheet2") 'Email Addresses
lRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set OutApp = CreateObject("Outlook.Application")
Select Case Target.Column


Case Is = 8
Select Case Target.Value
Case "ADAM1"
Set rng = srcWS5.Range("A12:B" & lRow)
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Join(Application.WorksheetFunction.Transpose(addrWS.Range("AJ2", addrWS.Range("AJ" & Rows.Count).End(xlUp)).Value), ";")
.cc = Join(Application.WorksheetFunction.Transpose(addrWS.Range("AK2", addrWS.Range("AK" & Rows.Count).End(xlUp)).Value), ";")
.Subject = srcWS5.Range("A9")
.HTMLBody = RangetoHTML(rng)
.Display
End With
End Select


If I step over that line and step through the rest of the code it creates the email as required, however omits the email address listed in the cell AJ2 where there is an email address listed in Sheet2.

Can you assist please?
 
Upvote 0
We've had so many changes that I have lost track of what the data in the sheets actually looks like.
Could you please use the XL2BB add-in (icon in the menu) to attach screenshots (not pictures) of each sheet? Using the XL2BB add-in allows me to copy the sheet data exactly as it appears in your actual workbook. An easier alternative would be to upload a copy of your file (de-sensitized if necessary), 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. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data.
 
Upvote 0
Hi Mumps,

Sure....so I've copied the simplified spreadsheet by sheet,

Sheet1
ABCDEFGHIJKLMNOPQRSTUV
LUX
03/07/2024 12:04​
TRWN/ADECO1BARC03/07/2024 12:05JPMC
03/07/2024 12:05​
DECO2
LON
02/07/2024 15:36​
N/AN/ADECO1N/AN/A
DUB
02/07/2024 15:36​
ADAM1ADAM2N/AN/ADECO1N/AN/A


Sheet2
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAM
SS LUX Email ListEmail CC:Subject HeadingFile AttachmentsSS LON Email ListEmail CC:Subject HeadingFile AttachmentsSS DUB Email ListEmail CC:Subject HeadingFile AttachmentsBARC Email ListEmail CC:Subject HeadingFile AttachmentsJPM Email ListEmail CC:Subject HeadingFile AttachmentsTRW - Email To:Email CC:Subject HeadingFile AttachmentsDEC1/2 - Email To:Email CC:Subject HeadingFile AttachmentsADAM - Email To:Email CC:Subject HeadingFile Attachments

Sheet3
ARAI
SS Lux Email TemplateSS Lon Email TemplateSS Dub Email Template
SubjectSubjectSubject
STATUS OF BLAH BLAHSTATUS OF BLA BLADADADADDADADADADA

Sheet4
AE
Barc Email TemplateJPM Email Template
SubjectSubject
BLAHDADA


Sheet5
A
TRW Email Template
Subject
MRDRV
Dear Sir/Madam


Sheet6
AL
DECO1 Email TemplateDECO2 Email Template
SubjectSubject
blahdadada


Sheet7
AH
ADAM1 Email TemplateADAM2 Email Template
SubjectSubject
blahdada


...and the 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,H:H,J:J,L:L,M:M,O:O,R:R")) Is Nothing Then Exit Sub
'If Target.Column <> 5 Then Exit Sub
Application.ScreenUpdating = False
Dim rng As Range, lRow As Long, srcWS As Worksheet, srcWS2 As Worksheet, srcWS3 As Worksheet, srcWS4 As Worksheet, srcWS5 As Worksheet, addrWS As Worksheet, OutApp As Object, OutMail As Object

Set srcWS = Sheets("Sheet3")
Set srcWS2 = Sheets("Sheet4")
Set srcWS3 = Sheets("Sheet5")
Set srcWS4 = Sheets("Sheet6")
Set srcWS5 = Sheets("Sheet7")
Set addrWS = Sheets("Sheet2") 'Email Addresses
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:P" & 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("R12:AG" & 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("R3")
.HTMLBody = RangetoHTML(rng)
.Display
End With
Case "DUB"
Set rng = srcWS.Range("AI5:AX" & 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("AI3")
.HTMLBody = RangetoHTML(rng)
.Display
End With
End Select
Target.Offset(, 1) = Now()
Application.ScreenUpdating = True





'Case Is = 8
' Select Case Target.Value
' Case "ADAM1"
' Set rng = srcWS5.Range("A12:B" & lRow)
' Set OutMail = OutApp.CreateItem(0)
' With OutMail
' .To = Join(Application.WorksheetFunction.Transpose(addrWS.Range("AJ2", addrWS.Range("AJ" & Rows.Count).End(xlUp)).Value), ";")
' .cc = Join(Application.WorksheetFunction.Transpose(addrWS.Range("AK2", addrWS.Range("AK" & Rows.Count).End(xlUp)).Value), ";")
' .Subject = srcWS5.Range("A9")
' .HTMLBody = RangetoHTML(rng)
' .Display
' End With
' End Select



Case Is = 10
Select Case Target.Value
Case "TRW"
Set rng = srcWS3.Range("A6:J" & lRow)
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Join(Application.WorksheetFunction.Transpose(addrWS.Range("Z2", addrWS.Range("Z" & Rows.Count).End(xlUp)).Value), ";")
.cc = Join(Application.WorksheetFunction.Transpose(addrWS.Range("AA2", addrWS.Range("AA" & Rows.Count).End(xlUp)).Value), ";")
.Subject = srcWS3.Range("A3")
.HTMLBody = RangetoHTML(rng)
.Display
End With
End Select
Case Is = 12
Select Case Target.Value
Case "DECO1"
Set rng = srcWS4.Range("A5:I" & lRow)
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Join(Application.WorksheetFunction.Transpose(addrWS.Range("AE2", addrWS.Range("AE" & Rows.Count).End(xlUp)).Value), ";")
.cc = Join(Application.WorksheetFunction.Transpose(addrWS.Range("AF2", addrWS.Range("AF" & Rows.Count).End(xlUp)).Value), ";")
.Subject = srcWS4.Range("A3")
.HTMLBody = RangetoHTML(rng)
.Display
End With
End Select
Case Is = 13
Select Case Target.Value
Case "BARC"
Set rng = srcWS2.Range("A7:C" & 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
Target.Offset(, 1) = Now()
Application.ScreenUpdating = True

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
End Select
Target.Offset(, 1) = Now()
Application.ScreenUpdating = True

Case Is = 18
Select Case Target.Value
Case "DECO2"
Set rng = srcWS4.Range("L5:U" & lRow)
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Join(Application.WorksheetFunction.Transpose(addrWS.Range("AE2", addrWS.Range("AE" & Rows.Count).End(xlUp)).Value), ";")
.cc = Join(Application.WorksheetFunction.Transpose(addrWS.Range("AF2", addrWS.Range("AF" & Rows.Count).End(xlUp)).Value), ";")
.Subject = srcWS4.Range("L3")
.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


So the code that's failing is Case 8 which I've commented out and this relates to Sheet2 and the data in the range on Sheet7.

In Sheet1, column H, I type in ADAM1 no ther choice and it should create the email, taking the email addresses from Sheet2, columns AJ, AK and the data in Sheet 7 to create the email body.

What I also want to do is add into Sheet7 in another column details for another range to be populated as ADAM2 in column I on Sheet1 (I guess that will be Case 9), so I type ADAM2 and another email is created using a different range of data very similar to LON, LUX, DUB but it is not based on a choice, it's just ADAM2

Hope this helps.
Thank you
 
Upvote 0
I'm sorry but the way you posted your sheets makes it very difficult to reproduce the data in Excel. Please see Post #33 for instructions on how to post screenshots or to upload the file. Uploading the file would be easier and preferable. Also, when posting code, please use code tags.
 
Upvote 0
mumps said:
I'm sorry but the way you posted your sheets makes it very difficult to reproduce the data in Excel. Please see Post #33 for instructions on how to post screenshots or to upload the file. Uploading the file would be easier and preferable. Also, when posting code, please use code tags.
Click to expand...
Thank you Mumps.

I've copied a version of the file in dropbox here :

Dropbox

www.dropbox.com www.dropbox.com
 
Upvote 0
There are a couple of issues. In the Case 10 section of code, I think that you should replace the current line of code with this line because the data to copy starts at line 7 not line 6.
VBA Code: 
Set rng = srcWS3.Range("A7:J" & lRow)
Regarding the other problem, all of the lines of code that start with "join" will error out because there is only one email address in each column of Sheet2 so there is nothing to join. I would assume that in real life each column will have more than one email address so the error won't come up. Try adding a second line of email addresses in Sheet 2. If it is possible that one or more of those columns will ever have only one email address, please let me know and I will modify the code.
 
Upvote 0
mumps said:
There are a couple of issues. In the Case 10 section of code, I think that you should replace the current line of code with this line because the data to copy starts at line 7 not line 6.
VBA Code: 
Set rng = srcWS3.Range("A7:J" & lRow)
Regarding the other problem, all of the lines of code that start with "join" will error out because there is only one email address in each column of Sheet2 so there is nothing to join. I would assume that in real life each column will have more than one email address so the error won't come up. Try adding a second line of email addresses in Sheet 2. If it is possible that one or more of those columns will ever have only one email address, please let me know and I will modify the code.
Click to expand...
Hi Mumps,

Ok - so that's why Case 8 is failing because there is only one email for the ".To" and then when I step over the code and continue it generates the email showing all the address in the ".cc" (because there's more than one address) and nothing the the ".To". Understood.

I have amended that spreadsheet with line 7 instead of 6. Thank you.

Can you assist with the dealing with one email address please?
 
Upvote 0
This is what Case "LUX" would look like:
Rich (BB code): 
Case "LUX"
                    Set rng = srcWS.Range("A5:P" & lRow)
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        If lRow2 > 2 Then
                            .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), ";")
                        Else
                            .to = addrWS.Range("A2")
                            .cc = addrWS.Range("B2")
                        End If
                        .Subject = srcWS.Range("A3")
                        .HTMLBody = RangetoHTML(rng)
                        .Display
                    End With
Follow the range pattern (in red and blue) and modify all the other cases.
 
Upvote 0
mumps said:
This is what Case "LUX" would look like:
Rich (BB code): 
Case "LUX"
                    Set rng = srcWS.Range("A5:P" & lRow)
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        If lRow2 > 2 Then
                            .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), ";")
                        Else
                            .to = addrWS.Range("A2")
                            .cc = addrWS.Range("B2")
                        End If
                        .Subject = srcWS.Range("A3")
                        .HTMLBody = RangetoHTML(rng)
                        .Display
                    End With
Follow the range pattern (in red and blue) and modify all the other cases.
Click to expand...
Thank you Mumps.
I still get the same error which is weird....what I have done is added another email address to range A2
 
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,182
Members
453,021
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