VBA：代码因DoEvents的时间长度而暂停

时间：2019-03-13 12:22:41

标签： excel vba doevents

我有一个过程可以根据用户窗体上提供的用户输入生成报告。我已经实现了应有的错误处理，但是我的一个错误处理程序不能很好地与DoEvents配合使用。问题是我的主子LoopGenrtReport循环了另一个子GenerateReport，冻结了不同的时间长度，如果IF，GenerateReport子由于错误而退出了。我说的长度是可变的，因为有时是5秒，而有时则永远不会移至循环的下一个迭代。

我已经测试过删除进度条和Doevents的代码，这样做时，我发现该过程完全按预期运行。

我也测试了不使用Application.Interactive，但是使用进度条和Doevents来检查是否可能是问题所在，但是发生了同样的事情。

下面是代码：

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

注意：：仅当我因错误退出GenerateReport时，才会发生此行为。实际的错误是没有为当前InPut_Array(ii)项目找到任何交易。预期的行为是仅移动主子循环中的下一个迭代而不会出现问题。如果已调用的子项已退出，则不会影响主子项。

我花了很长时间尝试解决该问题，但无济于事。任何想法，建议或答案将不胜感激。

根据@Spring Filip的请求，下面提供了被调用子GenerateReport的压缩版本。 

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, Ammount, 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

1 个答案:

答案 0 :(得分：0)

@Enigmativity的评论让我质疑为什么我什至都使用DoEvents，所以我对自己说：“自我，如果您完全摆脱DoEvents怎么办？ Sleep Windows API函数以10ms的增量而不是DoEvents？”好吧，这就是我所做的，添加了FrmProgress.Repaint，它可以防止Excel长时间冻结，同时可以像我需要的那样更新进度条。

唯一的问题是，由于我定义的错误而退出GenerateReport时，仍然有一些滞后，但是与以前的操作相比，我可以接受。

如果其他人有一个更好的主意，或者您认为我的主意无法如我所愿，那么请告诉我。我100％愿意接受其他想法或解决方案。

修订代码： 

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函数/子： 

#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
相关问题
最新问题