VBA循环内Status Bar进度异常：跳至100%问题求助

你的状态栏直接跳至100%，核心是外层循环逻辑完全错位，加上几个细节干扰了状态栏更新，具体问题和修复如下：

核心问题 #

1. 外层k循环逻辑错误：你把完整的报表生成流程（创建文件夹、调用PrepareClassSheets、弹窗、打开资源管理器）都塞进了For k=1 To LR循环里，且每次循环都读取固定单元格（Starting Page的I10/I11）的客户信息——这意味着如果第一列只有1行数据（LR=1），循环只跑一次，状态栏直接跳到100%；即使LR大于1，每次循环也会重复生成同一客户的报表，还反复弹窗打断流程。
2. ScreenUpdating频繁开关：在循环内反复设置Application.ScreenUpdating = False/True，干扰了状态栏的实时刷新。
3. 耗时操作未关联进度：真正耗时的PrepareClassSheets调用在状态栏更新之后，且未在该过程中同步进度（不过外层循环逻辑错误是首要问题）。

修复后的代码 #

Public Sub ProduceReports()
    Dim a As Range
    Dim StartingWS As Worksheet
    Dim ClientFolder As String
    Dim ClientCusip As Variant
    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 PercentageCompleted As Integer ' 修正拼写错误
    Dim k As Long
    
    ' 初始化设置，仅执行一次
    Set StartingWS = ThisWorkbook.Sheets("Starting Page")
    PreparedDate = Format(Now, "mm.yyyy")
    Application.ScreenUpdating = False ' 开头关闭屏幕更新，全程保持
    LR = StartingWS.Cells(Rows.Count, 1).End(xlUp).Row ' 明确指定工作表，避免ActiveSheet干扰
    NumOfBars = 45
    Application.StatusBar = "[" & Space(NumOfBars) & "]"

    ' 外层循环：遍历第一列的每个客户（假设第一列是客户列表，可根据实际调整）
    For k = 1 To LR
        ' 从当前行读取客户信息（替换原固定读取I10/I11的逻辑）
        ClientFolder = StartingWS.Cells(k, 1).Value
        ClientCusip = StartingWS.Cells(k, 2).Value ' 示例：第二列存Cusip，可按需修改
        
        ' 更新状态栏
        PresentStatus = Int((k / LR) * NumOfBars)
        PercentageCompleted = Round((k / LR) * 100, 0) ' 直接用k/LR计算，避免中间变量误差
        Application.StatusBar = "[" & String(PresentStatus, "|") & Space(NumOfBars - PresentStatus) & "] " & PercentageCompleted & "% Complete"
        DoEvents ' 强制刷新状态栏
        
        ' 创建文件夹与导出路径（先判断是否存在，避免重复创建报错）
        ExportFile = "P:\DEN-Dept\Public\" & ClientFolder & " - " & ClientCusip & " - " & PreparedDate & "\"
        If Dir(ExportFile, vbDirectory) = "" Then
            MkDir ExportFile
        End If
        Exports = ExportFile
        
        ' 处理符合条件的账户
        Worksheets("Standby").Visible = True
        ' 尽量避免Activate，直接用变量操作（若PrepareClassSheets不需要激活，可省略此步）
        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
        Worksheets("Standby").Visible = False
    Next k
    
    ' 所有循环完成后执行收尾操作
    Application.ScreenUpdating = True
    Application.StatusBar = False ' 恢复状态栏默认状态
    MsgBox Prompt:="所有Class Action数据已准备完成。", Title:="任务完成"
    Call Shell("explorer.exe " & ExportFile, vbNormalFocus) ' 可按需调整为打开根目录或其他路径
End Sub

关键修复点 #

• 修正循环逻辑：外层k循环现在遍历第一列的每个客户，从当前行读取对应信息，不再重复处理同一客户。
• 统一屏幕更新设置：开头关闭ScreenUpdating，结束时再打开，避免频繁切换干扰刷新。
• 优化状态栏计算：直接用k/LR计算百分比，比原逻辑更准确，消除中间变量误差。
• 增加文件夹存在判断：用Dir检查文件夹，避免重复创建报错。
• 移除不必要的工作表激活：减少Activate调用，提升代码效率与稳定性。
• 收尾操作移到循环外：弹窗、打开资源管理器仅执行一次，不再打断循环流程。

内容的提问来源于stack exchange，提问作者Wallenbees