Of late I have been writing macros which require substantial amount of time to execute. (upwards of 5 minutes but some are significantly longer). One of the things I found useful in such cases (other than to wait) is to have Application.StatusBar tell me if it is moving or hung.
However, many times, the Application.Statusbar gets frozen at some value while the program moves ahead. How can this be rectified? Is there anyway we can prevent this so that the statusbar keeps moving as long as the program is moving? Thanks in advance.
I found that the freeze happens at my code when I have many items in the loop. I got around that by using the following code:
For RowNum = 1 To TotalRows
For ColNum = 1 To TotalCols
'code
If ColNum = 1 Then
If RowNum Mod 50 = 0 And ColNum = 1 Then
Application.StatusBar = Format(RowNum / TotalRows, "0%")& " Completed."
End If
Else: Exit For
End If
Next ColNum
Next RowNum
The loop updates the status bar once every 50 rows. This helped the code run a lot faster and eliminated the screen freezing up
Related
I have ~150 Queries in a Microsoft Excel file. Clicking "Refresh all" would freeze my PC and resulted in some of the data not being able to load correctly even though network connection is good.
I'm looking to find a way to program "Refresh All" button so that it load maybe 5 to 10 queries at a time then move on the the next. I tried that manually and it loads without any problem. Just 150 queries at a time is too much.
Tks.
I couldn't find any simple way of resolving your query, but I have some thougts of a kind of a workaround. Below you can find two VBA macros that may help you a bit. The first code lists all queries that you have in your workbook in a new tab:
Sub ListQueries()
'Add tab to list all queries
Dim wsQueries As Worksheet
Set wsQueries = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
wsQueries.Name = "Query list"
wsQueries.Range("a1").Value = "Query name"
Dim con As WorkbookConnection
For Each con In ThisWorkbook.Connections
If UCase(Left(con.Name, 8)) = "QUERY - " Then wsQueries.Range("a1048576").End(xlUp).Offset(1, 0).Value = con.Name
Next con
End Sub
When it is finished you can use the second one. This time it will loop through all queries and refresh them but only as many as you will define in this clause If counter = 10 Then Exit For - if you want 15 then feel free to amend it. For each refereshed query it will add 'Yes' in column B. When you run RefreshQueries it at first checks whether a query is marked as 'Yes' and omit it if it's true.
Sub RefreshQueries()
Dim counter As Byte
counter = 0
'Range with query names
Dim rQueries As Range
Dim rQuery As Range
Dim wsQueries As Worksheet
Set wsQueries = ThisWorkbook.Worksheets("Query list")
Set rQueries = wsQueries.Range("a2:a" & wsQueries.Range("a1048576").End(xlUp).Row)
wsQueries.Range("b1") = "Refreshed"
For Each rQuery In rQueries
If counter = 10 Then Exit For 'if more than 10 queries refreshed then exit loop
'If query is refreshed then omit it and go to next
If rQuery.Offset(0, 1) <> "Yes" Then
ThisWorkbook.Connections(rQuery.Value).Refresh
rQuery.Offset(0, 1) = "Yes"
counter = counter + 1
End If
Next rQuery
End Sub
To sum up, you should run ListQueries once and RefreshQueries as many times as required to refresh all of them.
I created a UDF below which is expected to work nicely. The idea is to calculated weighted average for a variable (cases need to meet the criteria). But when the range contains 50,000 rows (e.g. A1:A50000), this macro is just dead. Excel just keeps running for hours after hours without responding. I thought array in VBA is quick enough to handle 50,000 rows. I am wondering if there is a better way to do calculation when there are so many rows used.
Function SurpAvg(code As String, per As String, var As String, _
dt1 As Range, dt2 As Range)
Dim weight As Variant, fperiod As Variant, ftype As Variant, ann As Variant, surpx As Variant
Dim startdt As Date, enddt As Date
Dim pctL As Double, pctH As Double, surpL As Double, surpH As Double
Dim i As Long, j As Long, a() As Variant, b() As Variant, total As Double, totalWT As Double
ThisWorkbook.Activate
With Application
weight = .Transpose(Range(code).Value)
fperiod = .Transpose(Range("FY").Value)
ftype = .Transpose(Range("FT").Value)
ann = .Transpose(Range("ann").Value)
surpx = .Transpose(Range("surpx").Value)
End With
startdt = dt1.Value
enddt = dt2.Value
pctL = Range("PctL")
pctH = Range("PctH")
surpL = -Range("MaxSurp")
surpH = Range("MaxSurp")
i = -1
On Error GoTo ErrorHandler
For j = LBound(surpx) To UBound(surpx)
If ftype(j) = var And ann(j) > startdt And ann(j) <= enddt And _
IsNumeric(1 / weight(j)) And IsNumeric(1 / surpx(j)) And _
surpx(j) > surpL And surpx(j) < surpH Then
If InStr(fperiod(j), per) Then
i = i + 1
ReDim Preserve a(i) As Variant
ReDim Preserve b(i) As Variant
a(i) = surpx(j)
b(i) = weight(j)
End If
End If
NextJ:
Next j
ErrorHandler:
If Err Then Resume NextJ
surpL = WorksheetFunction.Percentile(a, pctL)
surpH = WorksheetFunction.Percentile(a, pctH)
total = 0: totalWT = 0
For j = LBound(a) To UBound(a)
totalWT = totalWT + b(j)
If a(j) < surpL Then
total = total + surpL * b(j)
ElseIf a(j) > surpH Then
total = total + surpH * b(j)
Else
total = total + a(j) * b(j)
End If
Next j
SurpAvg = total / totalWT
End Function
You're most likely facing an infinite goto-loop caused by faulty error handling, because the only On Error statement in the procedure is still in effect when execution blows up in the bottom part of the code.
Band-aid solution:
ErrorHandler:
If Err.Number <> 0 Then Resume NextJ
On Error GoTo ErrHandler
surpL = WorksheetFunction.Percentile(a, pctL)
surpH = WorksheetFunction.Percentile(a, pctH)
total = 0: totalWT = 0
For j = LBound(a) To UBound(a)
totalWT = totalWT + b(j)
If a(j) < surpL Then
total = total + surpL * b(j)
ElseIf a(j) > surpH Then
total = total + surpH * b(j)
Else
total = total + a(j) * b(j)
End If
Next j
SurpAvg = total / totalWT
ErrHandler:
End Function
That's bad, because we're not even bothering to try to figure out what's wrong, because it's substituting proper flow control for error handling. If there's a logic bug (e.g. the error we're ignoring is some subscript out of range error), then such error handling is preventing the bug from being surfaced, and makes debugging much harder than it needs to be.
A real solution would involve avoiding the need to handle errors in the first place. For example by eliminating assumptions:
If totalWT <> 0 Then SurpAvg = total / totalWT
When you use On Error GoTo {label}, you should write your code in such a way that {label} can only ever be reached while in an error state:
Public Sub DoSomething()
On Error GoTo ErrHandler
'...
Exit Sub '<~ end of "happy path"
ErrHandler: '<~ begin "error path"
'...
End Sub
I put this here because it was too long for a comment and though I am only parroting what #Mathieu Guindon repeatedly suggested, it is worth repeating if it gets you on the right track.
I understand why you want good error handling but you are fixating on the wrong aspect. You can't have good error handling if you don't have a good handle on your errors.
Think about what it means to
[...] eliminate assumptions [... and ...] make operations conditional to certain specific conditions [...]
and how that helps you
[...] figure out what's wrong [...]
because
[...] substituting proper flow control for error handling [...]
is the main problem
[...] preventing the bug from being surfaced, and makes debugging much harder than it needs to be.
I narrowed your code down to focus on one variable. Look at it and see if you can find any assumptions that are not eliminated before your handler takes control, any operations that are not done under specific conditions, and if your code identifies or prevents anything that is wrong.
Function SurpAvg([...])
Dim surpx As Variant
[...]
ThisWorkbook.Activate
[...]
surpx = .Transpose(Range("surpx").Value)
[...]
On Error GoTo ErrorHandler
For j = LBound(surpx) To UBound(surpx)
[...]
NextJ:
Next j
ErrorHandler:
If Err Then Resume NextJ
[...]
End Function
The only assumptions I see eliminated are the ones eliminated be the default handler. Control is given to your handler without any preconditions, even the workbook is assumed with ThisWorkbook.Activate. The assumption is that the ActiveWorkbook is not calling outside code. If it is called by outside code, something commonly done with Personal.xlsb or an *.xlam add-in, then you will be working with the wrong workbook; consider 'Workbook1'Sheet1!A1 contains a UDF hosted in Personal, using ThisWorkbook means the function returns a value derived from data in Personal and not from data in 'Workbook1'Sheet1!A1
Take a close look at: surpx = .Transpose(Range("surpx").Value) This line is executed before control is assigned to your error handler, so an error here is handled by the default handler; but it can't catch logic errors and you may have an error here that is syntactically correct but still causes a run time error further in the code or perhaps cause an inaccurate result. For example:
Range("surpx") is not explicitly qualified. The named range
surpx can be scoped to a workbook and any number of individual
worksheets inside it. Your code assumes the active sheet is the
correct sheet and it will happily take unexpected values but at least the
default handler will alert you with an Error 1004 message if the
range does not exist.
Range("surpx").Value is blindly accepted and used without
preconditions. I am fond of div/0 errors, so consider what happens with one in that
range. surpx is a Variant so it happily takes the value of "Error
2007" without any issue until you try using it with For j = LBound(surpx) To UBound(surpx). This is the first line of code after
you've given authority to your handler so the default handler cannot help you and there is literally no
attempt to prevent, correct, or provide information that identifies
the error. The only thing your handler does is silently skip a block of
code. This is the antithesis of good error handling.
My advice, beyond what has already been said, revisit your data types to remove the variants, really think about how this code is called, explicitly qualify your objects, and even though this has been said, it is worth repeating again, use the default handler to debug the program before you enable a custom handler.
I have a simple SUB within an Excel VBA module that runs almost instantly and gives control back to the user with no noticeable delay - but only when I run the sub from Excel's Alt-F8 list of public subs.
When I run the same sub by launching it from a button or shape then it still runs almost instantly BUT on finishing takes about 3 seconds to give control back to the user. The Windows busy circle icon displays on the screen during this pause and Excel does not respond to any key presses.
So, why can launchng a sub from a button be so different to launching from Alt-F8?
(I know that the sub itself runs very quickly as I have tested it with a Timer wrapper which confirms that the actual code runs in less than 0.1 seconds)
The code is shown here, but I would've thought this almost irrelevant as the same code is being run but just being launched by different means.
Public Sub RefDel()
IX = ActiveCell.Row: IY = ActiveCell.Column
If Cells(IX, 2) = "R" And (IY = PlnNor Or IY = PlnRef) Then
II = MsgBox("Remove Reference?", 292, Cells(IX, PlnRef))
If II = vbYes Then
ProtOff
NOF = Cells(IX, PlnNor)
Rows(IX & ":" & IX + NRoRef - 1).Delete Shift:=xlUp
Do While Cells(IX, 2) = "R" ' Renumber subsequent rows
Cells(IX, PlnNor) = NOF
NOF = NOF + 1
IX = IX + NRoRef
Loop
Cells(IX - NRoRef, PlnRef).Select
ProtOn
End If
Else
MsgBox "Select a Reference", vbCritical, "Delete Reference"
End If
End Sub
I'm trying to learn how to use a progress bar with a userform.
The problem I have, with my code, is that it displays the progress bar after running the loop; it should be running the loop while showing the progress bar instead like 10%...20%...30%...40%......100%.
Can anyone help me fix my code to achieve this?
'-----Below is loop-----------------------------------------------------
Sub looprange()
Dim r As Range
'----------loop thru 0 to 9 ---------------
For Each r In Sheet6.Range("j2", Range("j" & Rows.Count).End(xlUp))
Sheet6.Range("i2").Value = r.Value
ActiveWindow.ScrollRow = 11
Application.CutCopyMode = False
Call print_jpeg
Next r
MsgBox "done"
End Sub
--
'--------Below is vba code in userform :------------
Private Sub UserForm_Activate()
Dim remainder As Long
Dim i As Long, j As Long
Call looprange
remainder = 0
For i = 1 To 200
UserForm1.Label2.Width = UserForm1.Label2.Width + 1
If i Mod 2 = 0 Then
remainder = remainder + 1
UserForm1.Caption = remainder & ” % complete”
UserForm1.Label2.Caption = remainder & “%”
End If
For j = 1 To 600
DoEvents
Next j
Next i
MsgBox “Loading of program complete.”
Unload UserForm1
End Sub
I believe a true status bar is not included in standard VBA (without references), however you can abuse a label control. Be aware that this method trades performance for user clarity (the user can see that the application is working, but it is slower than the same application without the status bar)
Simply add three labels, one for status text, one for the actual moving bar and one for full bar border. And format them to fit your application (see image below):
Code below:
Private Sub cbStart_Click()
one_percent_bar_width = lLoadBar.Width / 100 'width of one percent of the total loading bar
max_numbers = 1000 'only for demo purpose
Me.lLoadingBar.Visible = True
For i = 0 To max_numbers 'your loop here
'your code here
percentage = i / max_numbers * 100 'calculation of progress, replace i and max_numbers to fit your loop
Me.lStatus.Caption = percentage & "% complete" 'status percentage text
Me.lLoadingBar.Width = percentage * one_percent_bar_width 'width of actual blue bar
DoEvents 'slows down code but only way to make the bar visibly move, tradeoff between user clarity and speed
Next i 'edit to fit your loop
Me.lStatus.Caption = "Complete!" 'adjust status to whatever you want
End Sub
Private Sub UserForm_Initialize()
Me.lLoadingBar.Visible = False 'hide the small blue bar
Me.lStatus.Caption = "Progress not started" 'adjust status to whatever you want
End Sub
There are a few issues with your code, but to focus on the Progress Bar part, I'll share an example of one way to handle a progress bar in Excel (using the built-in status bar).
Instead of actually doing anything useful, this example is pausing for a split second between loops, but reports the status on the status bar.) Hopefully it will give you some ideas.
Sub ProgressBarTest()
Const LoopsToRun = 500
Dim z As Integer
For z = 1 To LoopsToRun
'put a random number in A1
Range("A1") = Int(Rnd() * 100) + 1
'update status bar
Application.StatusBar = "Progress: " & Format((z / LoopsToRun), "0.0%")
'pause for .3 seconds (instead of pausing, you'd run your actual procedure here)
Pause (0.1)
Next z
Application.StatusBar = "Complete!"
End Sub
Sub Pause(sec As Single)
'pauses for [sec] second
Dim startTime As Single
startTime = Timer
Do While Timer < startTime + sec
DoEvents
Loop
End Sub
More info here and here.
VBA has a progress bar control that can be added to forms. While you are learning, you can simply add this control to the form and then update that control during the loop where you are doing the useful form functions. The progress bar controls includes useful properties such as min and max.
If you are doing multiple things in your form, you can update a label to tell the user what is progressing as well as the amount of progress.
[More advanced] In some of my previous work, I have set up VBA routines to run in the background and created a progress bar form using events. This allows for a more sophisticated view with progress statements as well as a percentage run. But the basis of this form is still the progress bar control. While using events is more complicated it allowed me to make a more general progress bar form that can be used by any of my vba functions and these functions are then unaffected by any changes I make to the form because the events act as a kind of standard interface.
Update from a comment by #MathieuGuindon: "The control is actually a VB6 control and will only work in a 32-bit VBA host with the .OCX properly registered, which is getting more and more challenging to do with the more recent Windows versions; referencing and using these controls in VBA7 is heavily discouraged."
Is there a way to say to the code that, everytime there is an error, cancel what it's previously done?
For example, I have a code which creates 6 workbooks and when there is an error at the half of the code I have to cancel every workbook and launch the macro again!
thanks in advance
You can try:
Application.UnDo
in your error code. It does not always work.
VBA execution causes the Undo history to be erased
code that changes the interface in any way will clear the Undo buffer (stack)
the history is a list (or collection) of strings
Application.CommandBars("Standard").Controls("&Undo").Control.ListCount is 0
but you might be able to do something like this
Option Explicit
Public Sub makeFiles()
Dim i As Long, currentWB As Long, newWBs As Long
On Error GoTo cancelAction
currentWB = Workbooks.Count
For i = 1 To 6
Workbooks.Add
newWBs = newWBs + 1
ActiveSheet.Cells(1, 1).Value = 4
'generate an error
If i = 3 Then Workbooks.Item(Workbooks.Count + 1).Activate
Next
cancelAction:
Do While newWBs > 0 'Workbooks.Count > 1
Workbooks(currentWB + newWBs).Close False
newWBs = newWBs - 1
Loop
End Sub