Solved

Sub Timer

Posted on 2014-02-10
4
277 Views
Last Modified: 2014-02-11
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-
0
Comment
Question by:RWayneH
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 2
  • 2
4 Comments
 
LVL 27

Accepted Solution

by:
MacroShadow earned 500 total points
ID: 39848414
Sub Timer()

    Dim dtStart As Date
    Dim dtEnd As Date
    dtStart = Now
    ' Your code
    ' Your code
    ' Your code
    ' Your code
    dtEnd = Now
    MsgBox Format(DateDiff("s", dtStart, dtEnd) / 86400, "HH:MM:SS")

End Sub

Open in new window

0
 

Author Comment

by:RWayneH
ID: 39848455
Cool, do you think there is a way to incorporate this into an automated email that I send out with this?  How would I add this to the Body of the email?  Email code is below and it is the last thing that the procedure does.  I was thinking a new row with text: Runtime: then whatever the time was.  Please advise and thanks. -R-

'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."
'                .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
    
    

Open in new window

0
 
LVL 27

Expert Comment

by:MacroShadow
ID: 39848498
    
'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

Open in new window

0
 

Author Closing Comment

by:RWayneH
ID: 39850917
EXCELlent!!  Thanks. -R-
0

Featured Post

Office 365 Training for IT Pros

Learn how to provision tenants, synchronize on-premise Active Directory, implement Single Sign-On, customize Office deployment, and protect your organization with eDiscovery and DLP policies.  Only from Platform Scholar.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

I was prompted to write this article after the recent World-Wide Ransomware outbreak. For years now, System Administrators around the world have used the excuse of "Waiting a Bit" before applying Security Patch Updates. This type of reasoning to me …
Outlook for dependable use in a very small business   This article is about using the Outlook application (part of Microsoft Office) in a very small business, or for homeowners where dependability and reliability are critical requirements. This …
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

696 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question