在循环中使用状态栏

Question

我正在努力使我的状态栏与我的循环正确工作。我正在使用application.screenupdating = false，这样人们就不会看到我的过程有多混乱。但由于它正在运行，它可能需要2-5分钟才能完成。我试着使用教程中的代码来显示进度，但是它立即跳转到100%，而不是用循环数来跟踪。

Public Sub ProduceReports()
    Dim a As Range
    Dim StartingWS As Worksheet
    Dim ClientFolder As String
    Dim ClientCusip
    Dim ExportFile As String
    Dim PreparedDate As String
    Dim Exports As String
    Dim AccountNumber As String
    Dim LR As Long
    Dim NumOfBars As Integer
    Dim PresentStatus As Integer
    Dim PercetageCompleted As Integer
    Dim k As Long
    '******** This is my status bar code*******************
    LR = Cells(Rows.Count, 1).End(xlUp).row
    NumOfBars = 45
    Application.StatusBar = "[" & Space(NumOfBars) & "]"
    For k = 1 To LR

        PresentStatus = Int((k / LR) * NumOfBars)
        PercetageCompleted = Round(PresentStatus / NumOfBars * 100, 0)

        Application.StatusBar = "[" & String(PresentStatus, "|") & Space(NumOfBars - PresentStatus) & "] " & PercetageCompleted & "% Complete"

        DoEvents
    
        Cells(k, 1).Value = k
      
        Set StartingWS = ThisWorkbook.Sheets("Starting Page")
        
        '************* This code creates the folder and sets the export path for the individual spreadsheets**********
        ClientCusip = ActiveWorkbook.Worksheets("Starting Page").Range("I11").Value
        ClientFolder = ActiveWorkbook.Worksheets("Starting Page").Range("I10").Value
        PreparedDate = Format(Now, "mm.yyyy")
        MkDir "P:\DEN-Dept\Public\" & ClientFolder & " - " & ClientCusip & " - " & PreparedDate
        ExportFile = "P:\DEN-Dept\Public\" & ClientFolder & " - " & ClientCusip & " - " & PreparedDate & "\"
        Exports = ExportFile
    
        Worksheets("Standby").Visible = True
        Sheets("Standby").Activate
        Application.screenUpdating = False
        
        '************* This is the loop to check the cells and set the offset value as elgible or ineligible**********
        For Each a In StartingWS.Range("G9:G29").Cells
            If a.Value = "Eligible" Then
                AccountNumber = a.Offset(0, -1).Value
                PrepareClassSheets AccountNumber, Exports
            End If
        Next a
        
        Sheets("Starting Page").Activate
        Application.screenUpdating = True
        Worksheets("Standby").Visible = False
         
        MsgBox Prompt:="Class Action Data for" & " " & ClientFolder & " " & "has been prepared.", Title:="Bear has completed his tasks."
             
        Call Shell("explorer.exe" & " " & ExportFile, vbNormalFocus)
          
        '************** End of the status bar*********
        If k = LR Then Application.StatusBar = False
        
    Next k
      
End Sub

我想，如果我在另一个循环之外关闭状态栏循环，它就能工作。我是不是漏掉了什么明显的东西？

Answer 1

我试图复制您的进度条的情况没有更新，但无法这样做。

但是，我将您的进度条更新程序重构到它自己的子例程中，并创建了一个测试子来测试这部分代码是如何工作的。此外，我还添加了sleep API，这样我们就可以看到进度条的作用了。

在我的测试中，这一切似乎都很好。

“守则”

这里是我为新的sleep和测试子使用的testing。

' Stop code execution for specified milliseconds
' Add this for the new sub as well as the testing sub.
#If VBA7 And Win64 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

下面是更新进度栏的子程序。

' This sub uses the Global Status Bar as
' a progress bar.
Public Sub UpdateProgressStatusBar( _
    currentStep As Long, _
    totalSteps As Long, _
    Optional numberOfBars As Long = 100 _
)
    Dim presentStatus As Long
    presentStatus = CLng((currentStep / totalSteps) * numberOfBars)
    
    Dim percetageCompleted As Long
    percetageCompleted = Round(presentStatus / numberOfBars * 100, 0)
        
    Application.StatusBar = "[" & String(presentStatus, "|") & _
        Space(numberOfBars - presentStatus) & "] " & _
        percetageCompleted & "% Complete"
        
    ' I don't think this is needed, but I'm not 100% sure
    DoEvents
       
    ' When Progress is 100% we need to
    ' clear the progress bar. Adding a sleep
    ' to this step to make it a better user
    ' experince giving them a chance to see
    ' it is complete.
    If currentStep >= totalSteps Then
        Sleep 300
        Application.StatusBar = False
    End If
End Sub

最后，这是测试潜艇。您可以使用它来查看它是否在您的系统上工作，并向其添加方案以查看您是否可以在代码中隔离问题。在我的测试中，这对我的系统非常有用。

' You can run all your tests here in
' isolation.
Private Sub TestUpdateProgressStatusBar()
    Const start As Long = 1
    Const total As Long = 45
    
    ' Adding Screen Updating to see if it
    ' effects anything.
    Application.ScreenUpdating = False
    
    Dim currentNum As Long
    For currentNum = start To total
        UpdateProgressStatusBar currentNum, total, 45
        Sleep 20
    Next
    
    Application.ScreenUpdating = True
End Sub