• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 289
  • Last Modified:

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-
0
RWayneH
Asked:
RWayneH
  • 2
  • 2
1 Solution
 
MacroShadowCommented:
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
 
RWayneHAuthor Commented:
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
 
MacroShadowCommented:
    
'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
 
RWayneHAuthor Commented:
EXCELlent!!  Thanks. -R-
0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now