Vba 进度条“；“没有回应”；

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

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

我尝试了

Application.screenUpdate=True

和

Application.Wait（现在+时间值（“0:00:01”））

，但是这似乎并没有足够地降低VBA代码的速度。还请注意，进度条所在的userform的Show Modal属性为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

---

通过

DoEvents

和/或

Repaint

完成此操作。 首先，只尝试使用DoEvents

pctdone=i/x
进步
.LabelCaption.Caption=“插入行”&i&“of”&x
.LabelProgress.Width=pctdone*（.FrameProgress.Width）
.Repaint“您是否尝试添加
DoEvents
？作为奖励，Excel可以对来自Windows的查询做出反应，因此不会将其视为crashed@Chronocidal非常感谢这已经解决了问题！！：）。注意：DoEvents可能会过度使用，导致屏幕闪烁等问题。根据循环执行所需的时间，最好结合使用进度条控件的.Refresh方法和仅在特定时间间隔执行的DoEvents。例如，如果您希望有1000次迭代，那么可以每一次迭代执行一次刷新，但每10次或100次迭代只能执行一次DoEvents。