Прогресс-бар "Не отвечает" - PullRequest
Новая
       9

Прогресс-бар "Не отвечает"

0 голосов
/ 22 мая 2018

У меня есть следующий код, который вызывает одну из трех процедур, а затем обновляет индикатор выполнения, чтобы пользователь знал, что VBA все еще работает.

Однако, когда индикатор выполнения показывает, что он отображается как «Белый», похоже на то, как выглядит Excel, когда он «не отвечает».Я полагаю, это связано с тем, что макрос работает быстро, чтобы одновременно обновлять индикатор выполнения.

Я пробовал Application.ScreenUpdating = True и Application.Wait (Now + TimeValue("0:00:01")), но, похоже, это недостаточно сильно замедляет код VBA.Также обратите внимание, что пользовательская форма, на которой находится индикатор выполнения, имеет свойство Показать модальное значение как ложное.

Код, который я использую ниже (а также снимок экрана)

Будем весьма благодарны за любые идеи и советы о том, как обеспечить успешное обновление индикатора выполнения.

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
...