I have a procedure that generates reports based on user input provided on a user-form. I have implemented error handling, as one should, but one of my error handlers is not playing well with DoEvents. The issue is that my main sub LoopGenrtReport, which loops another sub, GenerateReport, freezes up for varying lengths of time, IF, the GenerateReport sub is exited due to an error. I say varying lengths, because sometimes it's 5 seconds, and other times it never moves to the next iteration of the loop.
I have tested removing the code for the progress bar and Doevents, and in doing so, I found that the procedure works exactly as intended.
I have also tested without Application.Interactive, but WITH the progress bar and Doevents to see if that might be the issue, but the same thing occurs.
Below is the code:
Private Sub LoopGenrtReport(ByRef InPut_Array As Variant)
Dim ii As Long
Dim UBTailNum_Array As Long
Dim Filtered_Array As Variant
Dim LoopCounter As Long
Dim pctdone As Single
Application.ScreenUpdating = False
Application.Interactive = False
UBTailNum_Array = UBound(InPut_Array)
'Sheet_Array is a public variable as are StartDate and End Date
Filtered_Array = SubsetArray(Sheet_Array, StartDate, EndDate)
If IsEmpty(Filtered_Array) Then
MsgBox "No Transactions were found in the date range selected.", _
vbCritical, "Error: No Transactions Found"
GoTo ClearVariables
End If
'Release from memory
Erase Sheet_Array
'Show progress bar if more than one report _
is being generated
If UBTailNum_Array > 0 Then Call ShowPrgssBar
For ii = LBound(InPut_Array) To UBound(InPut_Array)
LoopCounter = LoopCounter + 1
pctdone = LoopCounter / (UBTailNum_Array + 1)
With FrmProgress
.LabelCaption.Caption = "Generating Report(s) " & LoopCounter & " of " & UBTailNum_Array + 1
.LabelProgress.Width = pctdone * (.FrameProgress.Width)
End With
DoEvents
Call GenerateReport(Filtered_Array, CStr(InPut_Array(ii)))
Next ii
ClearVariables:
StartDate = Empty
EndDate = Empty
ii = Empty
InPut_Array = Empty
UBTailNum_Array = Empty
Filtered_Array = Empty
LoopCounter = Empty
pctdone = Empty
Application.Interactive = True
Application.ScreenUpdating = True
End Sub
Note: This behavior occurs ONLY when I exit GenerateReport due to an error. The actual error is that no transactions were found for the current InPut_Array(ii) item. Expected behavior would be to just move the next iteration of the loop in the main sub without issue. There is nothing that would affect the main sub if the called sub is exited.
I have spent quite a long time trying to resolve the issue to no avail. Any ideas, suggestions, or answers would be greatly appreciated.
As Per Request of @Spring Filip, a condensed version of the called sub, GenerateReport has been provided below.
Option Explicit
Option Private Module
Sub GenerateReport(ByRef Source_Array As Variant, ByRef KeyTailNum As String)
Dim i As Long
Dim CompositeKey As String
Dim Dict1 As Dictionary
Dim ItemComp_Array As Variant
Dim Coll As Collection
Set Dict1 = New Dictionary
Dict1.CompareMode = TextCompare
Set Coll = New Collection
' Build dictionary that summarizes transactions
For i = LBound(Source_Array, 1) To UBound(Source_Array, 1)
If Source_Array(i, 6) = KeyTailNum Then
CompositeKey = vbNullString
If Source_Array(i, 5) <> "MRO VENDOR" Then
If Source_Array(i, 5) = "ISSUE FROM STOCK" Then
'buid collection of IFS PNs
Coll.Add Source_Array(i, 1)
End If
'CompositeKey = PN,PO,Amount,Exp Type
CompositeKey = Join(Array(Source_Array(i, 1), _
Source_Array(i, 4), _
Abs(Source_Array(i, 3)), _
Source_Array(i, 5), KeyTailNum), "~~")
If Dict1.Exists(CompositeKey) Then
ItemComp_Array = Split(Dict1.Item(CompositeKey), "~~")
Dict1.Item(CompositeKey) = Join(Array(ItemComp_Array(0), _
ItemComp_Array(1), _
(CDbl(ItemComp_Array(2) + CDbl(Source_Array(i, 3)))), _
ItemComp_Array(3), _
ItemComp_Array(4), 0), "~~")
Else
'Item = PN, PN Des, Amount, Exp Cat, Count, Place holder for averages
Dict1.Add CompositeKey, Join(Array(Source_Array(i, 1), _
Source_Array(i, 2), _
CDbl(Source_Array(i, 3)), _
Source_Array(i, 5), _
1, 0), "~~")
End If
Else
'Key = Exp Alpha Name; PN/Exp Remark; Rec Unique ID; Tail Number
CompositeKey = Join(Array(Source_Array(i, 1), _
Source_Array(i, 2), Source_Array(i, 7), KeyTailNum), "~~")
If Not Dict1.Exists(CompositeKey) Then
'Item = Exp Alpha Name; PN/Exp Remark; Amount; Exp Typ; Account;Rec Unique Id
Dict1.Add CompositeKey, Join(Array(Source_Array(i, 1), _
Source_Array(i, 2), _
CDbl(Source_Array(i, 3)), _
Source_Array(i, 5), _
Source_Array(i, 8), _
Source_Array(i, 7)), "~~")
End If
End If
End If
Next i
'Errors_Coll is public, BoolExitGenRprt is public
'**************************************************************************************************
'Conditional Exit of Sub
'**************************************************************************************************
'If there are no transactions found for this tail then go to the Next Tail Number if there is one
If Dict1.Count = 0 Then
Errors_Coll.Add KeyTailNum
BoolExitGenRprt = True
GoTo ClearAllVariables
End If
'**************************************************************************************************
'**************************************************************************************************
'Begin Other code to be executed
|
|
|
|
|
|
|
|
'End Other code to be excuted'
ClearAllVariables:
'Clear Variables
i = Empty
Set Dict1 = Nothing
CompositeKey = Empty
ItemComp_Array = Empty
Source_Array = Empty
End Sub
@Enigmativity 's Comment made me question why I am even using DoEvents in the first place, so I said to myself, "Self, What if you just get rid of DoEvents altogether and use the Sleep Windows API function at a 10ms increment instead of DoEvents?" Well, that's just what I did, with the addition of FrmProgress.Repaint and it prevents Excel from freezing for extended periods of time all while updating the progress bar like I need it to.
The only issue is that it when the GenerateReport is exited due to my defined error, there is still a bit of a lag, but compared to what it was doing before, I can live with it.
If any one else has a better idea, or if you think my idea will not work like I am hoping it will, then please let me know. I am 100% open to other ideas or solutions.
Amended code:
Private Sub LoopGenrtReport(ByRef InPut_Array As Variant)
Dim ii As Long
Dim UBTailNum_Array As Long
Dim Filtered_Array As Variant
Dim LoopCounter As Long
Dim pctdone As Single
Application.ScreenUpdating = False
Application.Interactive = False
UBTailNum_Array = UBound(InPut_Array)
'Sheet_Array is a public variable as are StartDate and End Date
Filtered_Array = SubsetArray(Sheet_Array, StartDate, EndDate)
If IsEmpty(Filtered_Array) Then
MsgBox "No Transactions were found in the date range selected.", _
vbCritical, "Error: No Transactions Found"
GoTo ClearVariables
End If
'Release from memory
Erase Sheet_Array
'Show progress bar if more than one report _
is being generated
If UBTailNum_Array > 0 Then Call ShowPrgssBar
For ii = LBound(InPut_Array) To UBound(InPut_Array)
LoopCounter = LoopCounter + 1
pctdone = LoopCounter / (UBTailNum_Array + 1)
With FrmProgress
.LabelCaption.Caption = "Generating Report(s) " & LoopCounter & " of " & UBTailNum_Array + 1
.LabelProgress.Width = pctdone * (.FrameProgress.Width)
End With
'***********************************
'Added these in place of 'DoEvents'
FrmProgress.Repaint
Call Sleep (10)
'***********************************
Call GenerateReport(Filtered_Array, CStr(InPut_Array(ii)))
Next ii
ClearVariables:
StartDate = Empty
EndDate = Empty
ii = Empty
InPut_Array = Empty
UBTailNum_Array = Empty
Filtered_Array = Empty
LoopCounter = Empty
pctdone = Empty
Application.Interactive = True
Application.ScreenUpdating = True
End Sub
Windows API Functions/subs:
#If VBA7 Then
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
#Else
Public Declare Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long)
#End If