Loop to apply Excel worksheet dropdown selections - excel

Question

I want to send template emails based on selections in an Excel worksheet.
I want to choose which email template and subject line from a dropdown selection in the worksheet. If empty, I want to skip.
The range with the dropdown options.
Dim cellrange As Range, cell As Range
Set cellrange = Range("H3:H500")
I use PowerShell and other scripting languages regularly. My VBA exposure is limited.
I created variables for the different email templates and the subject lines. I also found code that will send the emails. That part seems ok.
I receive one email instead of looping through however many emails based on the selections in the sheet.
I set the email templates and subject line in a range in a different sheet and created variables for them.
Set delivery = Sheets("EmailTemplates").Range("A5:A40")
Set address = Sheets("EmailTemplates").Range("A50:A90")
Set deliverysub = Sheets("EmailTemplates").Range("B2")
Set addresssub = Sheets("EmailTemplates").Range("B50")
I will also create this for the Meeting template and subject line. I've been trying to get it to work with these two first and getting varied results.
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim delivery As Range
Dim shipping As Range
Dim meeting As Range
Dim address As Range
Dim deliverysub As Range
Dim shippingsub As Range
Dim meetingsub As Range
Dim addresssub As Range
Dim template As Range
Set delivery = Sheets("EmailTemplates").Range("A5:A40")
Set address = Sheets("EmailTemplates").Range("A50:A90")
Set deliverysub = Sheets("EmailTemplates").Range("B2")
Set addresssub = Sheets("EmailTemplates").Range("B50")
Set rng = Nothing
On Error Resume Next
Dim cellrange As Range, cell As Range
Set cellrange = Range("H3:H500")
For Each cell In cellrange
If cell.Value = "" Then
Next cell
ElseIf cell.Value = "Delivery" Then
Set rng = delivery
Set SubjectLine = deliverysub
ElseIf cell.Value = "Shipping" Then
Set rng = address
Set SubjectLine = addresssub
ElseIf cell.Value = "Meeting" Then
Set rng = meeting
Set SubjectLine = meetingsub
End If
Next cell
On Error GoTo 0
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "myemail#email.com"
.CC = ""
.BCC = ""
.Subject = SubjectLine
.HTMLBody = RangetoHTML(rng)
.SEND 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
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"
'Copy the range and create a new workbook to past the data in
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
'Publish the sheet to a htm file
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
'Read all data from the htm file into RangetoHTML
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=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set rng = Nothing
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
End Sub

Answer 1

More like this:
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim ws As Worksheet, wsTemplates As Worksheet
Dim cell As Range, subj As String
Set ws = ActiveSheet
Set wsTemplates = ThisWorkbook.Worksheets("EmailTemplates")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In ws.Range("H3:H500").Cells
'What type of template are we using?
Select Case cell.Value
Case "Delivery"
Set rng = wsTemplates.Range("A5:A40")
subj = wsTemplates.Range("B2")
Case "Shipping"
Set rng = wsTemplates.Range("A50:A90")
subj = wsTemplates.Range("B50")
Case "Meeting"
'etc etc
Case Else
Set rng = Nothing 'not sending anything
End Select
If Not rng Is Nothing Then 'sending?
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "myemail#email.com"
.CC = ""
.BCC = ""
.Subject = subj
.HTMLBody = RangetoHTML(rng)
.SEND 'or use .Display
End With
End If
Next cell
End Sub