RWayneH
asked on
Sub Timer
I have some long running procedures that wait on SAP extracts. Is there a way to, at the beginning of a Sub to start a timer and when done, if the runtime displayed in a MsgBox? I am getting sick of going to a separate app to start a timer... and I seems to always forget to check the timer when it is done. Some run for over an hour.. Please advise and thanks. -R-
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
'Add the declarations to the top of the module
' Public dtStart As Date
' Public dtEnd As Date
'Don't forget to add this in the beginning of your processing code
' dtStart = Now
'Don't forget to add this at the end of your processing code
' dtEnd = Now
Sub Create_Mail_From_List()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim strto As String
Dim ccto As String
Dim bccto As String
' To:
For Each cell In ThisWorkbook.Sheets("EmailForShortageRpt").Range("H2:H25") 'will handle 24 reciptiants, chg H24 to H50 for more
If cell.Value Like "?*@?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next cell
' cc:
For Each cell In ThisWorkbook.Sheets("EmailForShortageRpt").Range("A2:A25")
If cell.Value Like "?*@?*.?*" Then
ccto = ccto & cell.Value & ";"
End If
Next cell
' bcc:
For Each cell In ThisWorkbook.Sheets("EmailForShortageRpt").Range("C2:C25")
If cell.Value Like "?*@?*.?*" Then
bccto = bccto & cell.Value & ";"
End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
If Len(ccto) > 0 Then ccto = Left(ccto, Len(ccto) - 1)
If Len(bccto) > 0 Then bccto = Left(bccto, Len(bccto) - 1)
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = strto
.CC = ccto
.BCC = bccto
' .Subject = Format(Now, "dd-mmm-yy h:mm:ss")
.Subject = Worksheets("EmailForShortageRpt").Range("J1") & " " & Format(Now, "mmm-dd-yyyy h:mm:ss") 'of listed s-sheet use J1 as Subject
.Body = "Bruce Shortage Report is complete and ready for review. No issues. " & vbNewLine & _
"Report can be found: \\na\All-World\Holland\rrw5 " & vbCrLf & vbNewLine & _
"For adds and deletes to this email, please advise. Thanks." & vbCrLf & _
"Runtime: " & Format(DateDiff("s", dtStart, dtEnd) / 86400, "HH:MM:SS")
' .Body = "Reports are complete and ready for review. No issues. " & vbCrLf & vbNewLine & _
' "Shortage Rpt complete andBuThis should be the second line." & vbCrLf & vbCrLf & vbNewLine & _
' "And a third line if you want." 'You can also add files like this:
'.Attachments.Add ("C:\test.txt")
.Send 'Or use Display.
'.Display
End With
On Error GoTo 0
Set OutMail = Nothing
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
ASKER
EXCELlent!! Thanks. -R-
ASKER
Open in new window