Question

我有下面的代码调用三个过程之一，然后更新进度条让用户知道VBA仍在工作。

然而，当进度条显示它显示为“白色”时类似于excel在“无响应”时的外观。我相信这是由于宏工作快速同时更新进度条。

我尝试了Application.ScreenUpdating = True和Application.Wait (Now + TimeValue("0:00:01"))但是这似乎并没有足够减慢VBA代码的速度。另请注意，进度条所在的用户窗体将“显示模式”属性设置为false。

我在下面使用的代码（以及截图）

如何确保进度条成功更新的任何想法/提示将不胜感激。

Private Sub Ok_Btn_Click()

Dim x As Long
Dim i As Long
 i = 0
 x = Userentry.Value
Unload Me
Dim pctdone As Single

 'Display your Progress Bar
 ufProgress.LabelProgress.Width = 0
 Application.Wait (Now + TimeValue("0:00:01")) 'sleep to let progress bar show
 ufProgress.Show
 Application.Wait (Now + TimeValue("0:00:01")) 'sleep to let progress bar show

 Do Until i = x
 If ActiveSheet.Name = "Other Expenditure" Then Call InsertRowOtherExpenditure
 If ActiveSheet.Name = "Blended Rates" Then Call InsertRowBlendedRates
 If ActiveSheet.Name = "Development Centres" Then Call InsertRowDC

Application.ScreenUpdating = True
Application.Wait (Now + TimeValue("0:00:01")) 'sleep to let progress bar show
pctdone = i / x
With ufProgress
    .LabelCaption.Caption = "Inserting Row " & i & " of " & x
    .LabelProgress.Width = pctdone * (.FrameProgress.Width)
End With
Application.ScreenUpdating = False
i = i + 1
Loop

Unload ufProgress

End Sub

Answer 1

使用DoEvents和/或Repaint完成此操作。首先尝试仅使用DoEvent。

<snip...>

pctdone = i / x
With ufProgress
    .LabelCaption.Caption = "Inserting Row " & i & " of " & x
    .LabelProgress.Width = pctdone * (.FrameProgress.Width)
    .Repaint ' <-- HERE.
End With
DoEvents ' <-- HERE.
Application.ScreenUpdating = False


<.../snip>

来自@Bill Hileman的评论（一些不错的建议）。

注意事项：DoEvents可能被过度使用，并且可能导致屏幕闪烁以及其他问题。根据执行循环所花费的时间，最好结合使用进度条控件的.Refresh方法和仅以特定间隔执行的DoEvents。例如，如果您希望有1,000次迭代，则可以在每个迭代中执行一次Refresh，但每10或100次迭代中只执行一次DoEvent。

进度条“没有回应”

1 个答案: