Hi There All,
I have the following code which works quite well which I would like to update to incorporate a more dynamic "Subject" within an Email.
I have a spreadsheet with 2 sheets - In sheet 1, there is a cell with the Subject for an Email Subject Line along with a table which gets imported into an email.
In sheet 2, there is another table with names in column A, Yes/No in column B, email addresses in column C and file addresses in column E.
Sheet 2
What I would like the code to do is to add the information from Sheet 2 in column D to the Subject in column C, if the information in column B is Yes. If no, move on to the next line.
So the Subject line in each email will read:
First Email
Subject : MM - Test for FIN (BA)
Second Email
Subject : MM - Test for FIN (BNYM)
The code I have is :
Sub MMT()
Dim rng As Range
Dim rng2 As Range
Dim OutApp As Object
Dim OutMail As Object
Dim str1, str2, str3 As String
Dim edress As String
Dim subj As String
Dim Worksheet As Range
Dim ThisWorkbook As Object
Dim sMail_ids As String
Dim sMail_ids2 As String
Dim myDataRng3 As Range
dpath = Sheet1.Range("C7")
'Look in column B9 onward, where Yes/No would reside
LastRow = Sheet8.Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If UCase(Cells(i, 2).Value) = "YES" Then
'Address is offset 1 row above, Mail Body 1 row below
emailTo = Cells(i, 2 + 1).Value
' emailBody = Sheet3.Range("B10 - C22").Value
'looping through all the files and attaching them to an Email
iRow = 9
' We'll now set a range for the .Subject entered into the "Money Market" tab in Cell "C8".
Set myDataRng3 = Sheet3.Range("C8:C8") '& Cells(Rows.Count, "C8").End(xlUp).Row)
' Run a loop to extract email ids from the 3rd column.
For Each cell In myDataRng3
If Trim(subj) = "" Then
subj = cell.Offset(0, 0).Value
Else
subj = subj & vbCrLf & ";" & cell.Offset(0, 0).Value
End If
Next cell
Set myDataRng = Nothing ' Clear the range.
'=========================================================================================
'First Range called MMRange can be increased if multiples are required and these will appear in the email.
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Sheets("Money Market").Range("MMRange").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
'==========================================================================================
'Second Range called B24:C50 is the wording for the email.
Set rng2 = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng2 = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng2 = Sheets("Money Market").Range("B24:C50").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng2 Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
'==========================================================================================
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
str1 = "<Body style = font-size:11pt;font-family:Arial>" & _
"Good Afternoon, <br><br> Please open under this arrangement. <br>"
str2 = "<br>If you have any queries with regard to this matter, then please contact me.<br>"
str3 = "<br>Best regards,<br> Stephen"
'Dim OutApp As Object
'Dim OutMail As Object
On Error Resume Next
With OutMail
.To = emailTo ' Assign all email ids to the property.
.CC = "Stephen.Preece" ' Assign all email ids to the property.
.BCC = ""
.Subject = subj
.HTMLBody = str1 & RangetoHTML(rng) & RangetoHTML(rng2) & .HTMLBody & str2 & str3 '.HTMLBody
'Selects all the files listed in column E
Do While Cells(iRow, 5) <> Empty
'picking up file name from column E (5)
pfile = Dir(dpath & "\" & Cells(iRow, 5) & "" & "")
'checking for file exist in a folder and if its a requested file from the list
'.Attachments.Add (dpath & Cells(irow, 5) & pfile)
.Attachments.Add (Cells(iRow, 5) & pfile)
'go to next file listed in column E (5)
iRow = iRow + 1
Loop
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
'Cells(i, 2).value = "No"
Next
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
ublishsource=", _
"align=left xublishsource=")
'Close TempWB
TempWB.Close SaveChanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
I have the following code which works quite well which I would like to update to incorporate a more dynamic "Subject" within an Email.
I have a spreadsheet with 2 sheets - In sheet 1, there is a cell with the Subject for an Email Subject Line along with a table which gets imported into an email.
| Sheet 1 Column A | Column B | Column C |
| File Location : | Z:\GMM\ | |
| Subject : | MM - Test for FIN |
| LEName | Test1 | |
| FName | Test2 | |
| DCode | Test3 | |
| CBank | Test4 | |
| NAValue | Test5 |
In sheet 2, there is another table with names in column A, Yes/No in column B, email addresses in column C and file addresses in column E.
Sheet 2
| Column A | Column B | Column C | Column D | Column E |
| BA NA | Yes | testemail; | (BA) | Z:\GMM\Test.pdf |
| BNYM | Yes | testemail | (BNYM) | Z:\GMM\Test1.pdf |
What I would like the code to do is to add the information from Sheet 2 in column D to the Subject in column C, if the information in column B is Yes. If no, move on to the next line.
So the Subject line in each email will read:
First Email
Subject : MM - Test for FIN (BA)
Second Email
Subject : MM - Test for FIN (BNYM)
The code I have is :
Sub MMT()
Dim rng As Range
Dim rng2 As Range
Dim OutApp As Object
Dim OutMail As Object
Dim str1, str2, str3 As String
Dim edress As String
Dim subj As String
Dim Worksheet As Range
Dim ThisWorkbook As Object
Dim sMail_ids As String
Dim sMail_ids2 As String
Dim myDataRng3 As Range
dpath = Sheet1.Range("C7")
'Look in column B9 onward, where Yes/No would reside
LastRow = Sheet8.Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If UCase(Cells(i, 2).Value) = "YES" Then
'Address is offset 1 row above, Mail Body 1 row below
emailTo = Cells(i, 2 + 1).Value
' emailBody = Sheet3.Range("B10 - C22").Value
'looping through all the files and attaching them to an Email
iRow = 9
' We'll now set a range for the .Subject entered into the "Money Market" tab in Cell "C8".
Set myDataRng3 = Sheet3.Range("C8:C8") '& Cells(Rows.Count, "C8").End(xlUp).Row)
' Run a loop to extract email ids from the 3rd column.
For Each cell In myDataRng3
If Trim(subj) = "" Then
subj = cell.Offset(0, 0).Value
Else
subj = subj & vbCrLf & ";" & cell.Offset(0, 0).Value
End If
Next cell
Set myDataRng = Nothing ' Clear the range.
'=========================================================================================
'First Range called MMRange can be increased if multiples are required and these will appear in the email.
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Sheets("Money Market").Range("MMRange").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
'==========================================================================================
'Second Range called B24:C50 is the wording for the email.
Set rng2 = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng2 = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng2 = Sheets("Money Market").Range("B24:C50").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng2 Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
'==========================================================================================
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
str1 = "<Body style = font-size:11pt;font-family:Arial>" & _
"Good Afternoon, <br><br> Please open under this arrangement. <br>"
str2 = "<br>If you have any queries with regard to this matter, then please contact me.<br>"
str3 = "<br>Best regards,<br> Stephen"
'Dim OutApp As Object
'Dim OutMail As Object
On Error Resume Next
With OutMail
.To = emailTo ' Assign all email ids to the property.
.CC = "Stephen.Preece" ' Assign all email ids to the property.
.BCC = ""
.Subject = subj
.HTMLBody = str1 & RangetoHTML(rng) & RangetoHTML(rng2) & .HTMLBody & str2 & str3 '.HTMLBody
'Selects all the files listed in column E
Do While Cells(iRow, 5) <> Empty
'picking up file name from column E (5)
pfile = Dir(dpath & "\" & Cells(iRow, 5) & "" & "")
'checking for file exist in a folder and if its a requested file from the list
'.Attachments.Add (dpath & Cells(irow, 5) & pfile)
.Attachments.Add (Cells(iRow, 5) & pfile)
'go to next file listed in column E (5)
iRow = iRow + 1
Loop
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
'Cells(i, 2).value = "No"
Next
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
ublishsource=", _"align=left x
ublishsource=")'Close TempWB
TempWB.Close SaveChanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
