Hi Everyone,
I have a workbook with several sheets within it and there is a 'Control' sheet which is used mainly to create individual spreadsheets (based on some of the sheets within the workbook) for audit purposes. Also within the workbook, there is an email sheet called 'Sheet2' (just haven't got round to renaming it yet) which has groups of email teams used to send the audit created spreadsheets.
Lastly, I have a 'log/tracker' sheet - this is used to track where I am within the process of generating/sending the data.
What I am after is when I create the email, is to check the data within the sheet (MWIRE_DSMatch - column D) within the workbook and then go to the 'log/tracker' sheet, check if the data has been input here (column E) and if it has find the cell/row in column L and populate it with a comment 'SP - Email sent dd/mm/yyyy and time'. If not, create a new line inputting the data.
MWIRE_DSMatch image attached.
Log/tracker image attached.
The Email code:
Sub OTCEmailForDSMatch()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim str1, str2 As String
Dim edress As String
Dim subj As String
Dim Worksheet As Range
Dim ThisWorkbook As Object
Dim sMail_ids As String ' To store recipients email ids.
Dim sMail_ids2 As String ' To store recipients email ids.
Dim myDataRng As Range
Dim myDataRng2 As Range
Dim myDataRng3 As Range
'file path
dpath = "C:\Users\P3001951\Documents\"
' We'll now set a range for the .To.
Set myDataRng = Range("Z2:Z6" & Cells(Rows.count, "Z").End(xlUp).Row)
' We'll now set a range for the .CC.
Set myDataRng2 = Range("AA2:AA6" & Cells(Rows.count, "AA").End(xlUp).Row)
' We'll now set a range for the .Subject.
Set myDataRng3 = Range("AB2:AB2" & Cells(Rows.count, "AB").End(xlUp).Row)
' Run a loop to extract email ids from the 1st column.
For Each cell In myDataRng
If Trim(sMail_ids) = "" Then
sMail_ids = cell.Offset(0, 0).Value
Else
sMail_ids = sMail_ids & vbCrLf & ";" & cell.Offset(0, 0).Value
End If
Next cell
Set myDataRng = Nothing ' Clear the range.
' Run a loop to extract email ids from the 2nd column.
For Each cell In myDataRng2
If Trim(sMail_ids2) = "" Then
sMail_ids2 = cell.Offset(0, 0).Value
Else
sMail_ids2 = sMail_ids2 & vbCrLf & ";" & cell.Offset(0, 0).Value
End If
Next cell
Set myDataRng2 = Nothing ' Clear the range.
' Run a loop to extract Subject 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 myDataRng3 = Nothing ' Clear the range.
'looping through all the files and attaching them to an Email
iRow = 2
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("TradeWeb").Range("TradeWebGrid").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
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
str1 = "<Body style = font-size:12pt;font-family:Calibri>" & _
"Hi, <br><br> Please can you urgently set up the attached (highlighted in yellow) new DSMatch account/s along with the FCA/EMIR reporting functionality.<br>Please note the funds as detailed below and confirm when these have been completed.<br>"
str2 = "<br>We've used the new EMIR/FCA Data Gathering Sheets provided by you due to BREXIT and effective 01/01/2021 so in this occasion I'm Cc'ing the following;<br>Erval.Libohova@ihsmarkit.com<br>Robert.Schweikert@ihsmarkit.com<br>Megan.Heintschel@ihsmarkit.com<br><br>Best regards,<br> Stephen"
On Error Resume Next
With OutMail
.To = sMail_ids ' Assign all email ids to the property.
.CC = sMail_ids2 ' Assign all email ids to the property.
.BCC = ""
.Subject = subj
.HTMLBody = str1 & RangetoHTML(rng) & str2 & .HTMLBody
'.Send 'or use
'Selects all the files listed in column AC
Do While Cells(iRow, 29) <> Empty
'picking up file name from column AC (29)
pfile = Dir(dpath & "\~" & Cells(iRow, 29) & "*" & "~")
'checking for file exist in a folder and if its a requested file from the list
'.Attachments.Add (dpath & Cells(irow, 29) & pfile)
.Attachments.Add (Cells(iRow, 29) & pfile)
'go to next file listed in column AC (29)
iRow = iRow + 1
Loop
.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)
' Creates a temporary file
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 an html 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 a workbook with several sheets within it and there is a 'Control' sheet which is used mainly to create individual spreadsheets (based on some of the sheets within the workbook) for audit purposes. Also within the workbook, there is an email sheet called 'Sheet2' (just haven't got round to renaming it yet) which has groups of email teams used to send the audit created spreadsheets.
Lastly, I have a 'log/tracker' sheet - this is used to track where I am within the process of generating/sending the data.
What I am after is when I create the email, is to check the data within the sheet (MWIRE_DSMatch - column D) within the workbook and then go to the 'log/tracker' sheet, check if the data has been input here (column E) and if it has find the cell/row in column L and populate it with a comment 'SP - Email sent dd/mm/yyyy and time'. If not, create a new line inputting the data.
MWIRE_DSMatch image attached.
Log/tracker image attached.
The Email code:
Sub OTCEmailForDSMatch()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim str1, str2 As String
Dim edress As String
Dim subj As String
Dim Worksheet As Range
Dim ThisWorkbook As Object
Dim sMail_ids As String ' To store recipients email ids.
Dim sMail_ids2 As String ' To store recipients email ids.
Dim myDataRng As Range
Dim myDataRng2 As Range
Dim myDataRng3 As Range
'file path
dpath = "C:\Users\P3001951\Documents\"
' We'll now set a range for the .To.
Set myDataRng = Range("Z2:Z6" & Cells(Rows.count, "Z").End(xlUp).Row)
' We'll now set a range for the .CC.
Set myDataRng2 = Range("AA2:AA6" & Cells(Rows.count, "AA").End(xlUp).Row)
' We'll now set a range for the .Subject.
Set myDataRng3 = Range("AB2:AB2" & Cells(Rows.count, "AB").End(xlUp).Row)
' Run a loop to extract email ids from the 1st column.
For Each cell In myDataRng
If Trim(sMail_ids) = "" Then
sMail_ids = cell.Offset(0, 0).Value
Else
sMail_ids = sMail_ids & vbCrLf & ";" & cell.Offset(0, 0).Value
End If
Next cell
Set myDataRng = Nothing ' Clear the range.
' Run a loop to extract email ids from the 2nd column.
For Each cell In myDataRng2
If Trim(sMail_ids2) = "" Then
sMail_ids2 = cell.Offset(0, 0).Value
Else
sMail_ids2 = sMail_ids2 & vbCrLf & ";" & cell.Offset(0, 0).Value
End If
Next cell
Set myDataRng2 = Nothing ' Clear the range.
' Run a loop to extract Subject 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 myDataRng3 = Nothing ' Clear the range.
'looping through all the files and attaching them to an Email
iRow = 2
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("TradeWeb").Range("TradeWebGrid").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
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
str1 = "<Body style = font-size:12pt;font-family:Calibri>" & _
"Hi, <br><br> Please can you urgently set up the attached (highlighted in yellow) new DSMatch account/s along with the FCA/EMIR reporting functionality.<br>Please note the funds as detailed below and confirm when these have been completed.<br>"
str2 = "<br>We've used the new EMIR/FCA Data Gathering Sheets provided by you due to BREXIT and effective 01/01/2021 so in this occasion I'm Cc'ing the following;<br>Erval.Libohova@ihsmarkit.com<br>Robert.Schweikert@ihsmarkit.com<br>Megan.Heintschel@ihsmarkit.com<br><br>Best regards,<br> Stephen"
On Error Resume Next
With OutMail
.To = sMail_ids ' Assign all email ids to the property.
.CC = sMail_ids2 ' Assign all email ids to the property.
.BCC = ""
.Subject = subj
.HTMLBody = str1 & RangetoHTML(rng) & str2 & .HTMLBody
'.Send 'or use
'Selects all the files listed in column AC
Do While Cells(iRow, 29) <> Empty
'picking up file name from column AC (29)
pfile = Dir(dpath & "\~" & Cells(iRow, 29) & "*" & "~")
'checking for file exist in a folder and if its a requested file from the list
'.Attachments.Add (dpath & Cells(irow, 29) & pfile)
.Attachments.Add (Cells(iRow, 29) & pfile)
'go to next file listed in column AC (29)
iRow = iRow + 1
Loop
.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)
' Creates a temporary file
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 an html 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
