在循环内使用状态栏

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

API。

' 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.
' @require {function} Sleep API
Public Sub UpdateProgressStatusBar( _
    currentStep As Long, _
    totalSteps As Long, _
    Optional numberOfBars As Long = 100, _
    Optional fillSymbol As String = "|", _
    Optional nonFillSymbol As String = " ", _
    Optional debugLogStatus As Boolean = False _
)
    Dim percetageCompleted As Double
    percetageCompleted = Round(currentStep / totalSteps * 100, 0)
     
    ' Application.StatusBar has a maximum of
    ' 255 characters otherwise it will throw
    ' an error. Therefore, we need to make sure
    ' it doesn't go over the max. Grab the
    ' minimum between the passed in numberOfBars
    ' or the total length of known characters - 255
    ' max limit.
    Dim adjustedNumberOfBars As Long
    adjustedNumberOfBars = Application.WorksheetFunction.min( _
        255 - (Len(percetageCompleted) + Len("[] % Complete")), _
        numberOfBars _
    )
    
    Dim fillCount As Long
    fillCount = CLng((currentStep / totalSteps) * adjustedNumberOfBars)
    
    Application.StatusBar = "[" & _
        String(fillCount, fillSymbol) & _
        String(adjustedNumberOfBars - fillCount, nonFillSymbol) & _
        "] " & _
        percetageCompleted & "% Complete"
    
    ' I don't think this is needed, but I'm not 100% sure
    DoEvents
    
    If debugLogStatus Then
        Debug.Print currentStep, totalSteps, Application.StatusBar
    End If
       
    ' 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 500
        Application.StatusBar = False
    End If
End Sub

最后，这是测试子。您可以使用它来查看它是否适用于您的系统，并向其中添加场景以查看是否可以隔离代码中的问题。在我的测试中，这在我的系统上效果很好。

' You can run all your tests here in
' isolation.
Private Sub Test_UpdateProgressStatusBar()
    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, 100
        Sleep 20
    Next
    
    Application.screenUpdating = True
End Sub