Monitoring progress of Excel/VBA routines with a long runtime

[paparlz]

I've recently been running heavy VBA computations in Excel that run
for many hours. It would be useful to know how the job is
progressing. I've tried putting a progress message in the status
bar; this works for while but always hangs up eventually, even
thought he job is progressing satisfactorily. I've tried writing
messages to a worksheet; this performs in a simialr way - eventually
the sheet fails to update. For the job I'm running at the moment I
cannot even make the workbook visible in windows; it is listed on the
windows taskbar, but cannot be restored to view. I know that progress
monitors for VBA are out there - I have used one in the past. But
does anyone know why Excel fails to update its own status bar or make
itself visible in these circumstances?

 

[ryguy7272]

Sub ProgressBar()

Dim PB As clsProgBar
Set PB = New clsProgBar


With PB

..Title = "Progress Bar"
..Caption1 = "Executing, Please wait, this may take a short while..."
..Show
DoEvents


End With


PB.Progress = 5

'etc., etc., etc.
'notice, you will have to manually add PB.Progress = 10, 20 ... 50 ... 90
'add those intermittently between the lines of your code

PB.Progress = 100

The, create a UserForm and name it frmProgress. On the UserForm, create a
Label and name it lblMsg1, create a second Label and name it lblMsg2, and
finally, create an Image and name it imgProgFore.

Good luck,
Ryan---

 

[Patrick Molloy]

write to a log file. This should be a simple text file and the app just add
text to say where its at

so you would include lines like
WriteLog "Starting 2nd process"
WriteLog "End of 2nd process"

and so on, where WriteLog is a subroutine that would write the line to text
file

here's a rough demo
in the development environment, set a reference to Microsoft Scripting
Runtime and paste this to a module

Option Explicit

Sub test()
Dim t As Long
t = Timer
WriteLog "Starting at " & Format$(Now, "dd-mmm-yy HH:MM")
Do
DoEvents
Loop Until Timer > (t + 30)
WriteLog "Ending at " & Format$(Now, "dd-mmm-yy HH:MM")
End Sub

Sub WriteLog(sText As String)
Dim TXT As Scripting.TextStream
With New FileSystemObject
Set TXT = .OpenTextFile("C:\temp\mylogfile.txt", ForAppending, True)
TXT.WriteLine sText
TXT.Close
Set TXT = Nothing
End With
End Sub

 

[paparlz]

write to a log file. This should be a simple text file and the app just add
text to say where its at

so you would include lines like
WriteLog "Starting 2nd process"
WriteLog "End of 2nd process"

and so on, where WriteLog is a subroutine that would write the line to text
file

here's a rough demo
in the development environment, set a reference to Microsoft Scripting
Runtime and paste this to a module

Option Explicit

Sub test()
    Dim t As Long
    t = Timer
    WriteLog "Starting at " & Format$(Now, "dd-mmm-yy HH:MM")
    Do
        DoEvents
    Loop Until Timer > (t + 30)
    WriteLog "Ending at " & Format$(Now, "dd-mmm-yy HH:MM")
End Sub

Sub WriteLog(sText As String)
    Dim TXT As Scripting.TextStream
    With New FileSystemObject
        Set TXT = .OpenTextFile("C:\temp\mylogfile.txt", ForAppending, True)
        TXT.WriteLine sText
        TXT.Close
        Set TXT = Nothing
    End With
End Sub






- Show quoted text -

Thanks Patrick for this suggestion. Thanks also to Ryan for his
ealier progress bar code. Either of these will certainly do the job.
Why the status bar fails is still a mystery to me.

 

[Jim Cone]

Are you continually increasing the length of the status bar message?
There is a text length limitation in the status bar that would make it to appear to be static.
Another approach would be something like...
Application.StatusBar = "Figuring " & Format$(Counter/TotalCount, "#.00%")
--
Jim Cone
Portland, Oregon USA


"paparlz" <[email protected]>
wrote in message
I've recently been running heavy VBA computations in Excel that run
for many hours. It would be useful to know how the job is
progressing. I've tried putting a progress message in the status
bar; this works for while but always hangs up eventually, even
thought he job is progressing satisfactorily. I've tried writing
messages to a worksheet; this performs in a simialr way - eventually
the sheet fails to update. For the job I'm running at the moment I
cannot even make the workbook visible in windows; it is listed on the
windows taskbar, but cannot be restored to view. I know that progress
monitors for VBA are out there - I have used one in the past. But
does anyone know why Excel fails to update its own status bar or make
itself visible in these circumstances?

 

[RB Smissaert]

Here another simple statusbar progress routine:

Sub StatusProgressBar(lCounter As Long, _
lMax As Long, _
bReset As Boolean, _
Optional lInterval As Long = -1, _
Optional strLeadingText As String, _
Optional strTrailingText As String, _
Optional lLength As Long = 100)

'lCounter the loop counter passed from the procedure
'lMax the maximum of the loop counter
'bReset do this at the very first iteration, eg i = 0
'lInterval the update interval of the statusbar
'strText any text preceding the progressbar
'lLength lenght in characters of the progressbar
'---------------------------------------------------------
Dim lStripes As Long
Static lLenText As Long
Static strBuffer As String
Static lOldStripes As Long
Static lInterval2 As Long

If lMax = 0 Then
Exit Sub
End If

If bReset Then
lLenText = Len(strLeadingText)
strBuffer = strLeadingText
strBuffer = strBuffer & String(lLength, ".")
strBuffer = strBuffer & "|"
lOldStripes = 0

If lInterval = -1 Then
lInterval2 = (lMax / lLength) \ 2
Else
lInterval2 = lInterval
End If

If lInterval2 < 1 Then
lInterval2 = 1
End If
End If

If lCounter Mod lInterval2 = 0 Or lCounter = lMax Then
lStripes = Round((lCounter / lMax) * lLength, 0)

If lStripes > lOldStripes Then

Mid$(strBuffer, lLenText + 1 + lOldStripes) = String(lStripes -
lOldStripes, "|")
strBuffer = strBuffer & strTrailingText

If Len(strBuffer) = 0 Then
Application.StatusBar = False
Else
Application.StatusBar = strBuffer
End If

lOldStripes = lStripes

End If 'If lStripes > lOldStripes
End If 'If lCounter Mod lInterval2 = 0 Or lCounter = lMax

End Sub


The solution to your problem though is to use DoEvents.


RBS