Индикатор прогресса Excel VBA

Question

У меня есть этот Excel VBA-код, полученный из Интернета, в котором перечислены все файлы в папке.Моя проблема в том, что я хочу, чтобы индикатор прогресса подсказывал пользователю, что макрос все еще работает.

Вот код ...

Private Sub CommandButton1_Click()
Worksheets("GetFileList").Unprotect 'Unprotect Sheet
    Dim xRow As Long
    Dim xDirect$, xFname$, InitialFoldr$
    InitialFoldr$ = "C:\"
    Worksheets("GetFileList").Range("A4:a5000").Clear 'Clear selected range
    ActiveSheet.Range("a4").Select               'Set Focus

    With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = Application.DefaultFilePath & "\"
    .Title = "Please select a folder to list Files from"
    .InitialFileName = InitialFoldr$
    .Show
    If .SelectedItems.Count <> 0 Then
             xDirect$ = .SelectedItems(1) & "\"
             xFname$ = Dir(xDirect$, 7)
        Do While xFname$ <> ""
            ActiveCell.Offset(xRow) = xFname$
            xRow = xRow + 1
            xFname$ = Dir
           Loop
        End If
        End With
Worksheets("GetFileList").Protect UserInterfaceOnly:=True
MsgBox "Done Processing...!"
End Sub

Answer 1

Я использую следующий класс, который я улучшил для своих нужд.

В строке состояния Excel это выглядит примерно так:

---

1. Добавьте новый модуль класса и назовите его ProgressBar следующим кодом:

   Option Explicit
   
   Private statusBarState As Boolean
   Private enableEventsState As Boolean
   Private screenUpdatingState As Boolean
   Private Const NUM_BARS As Integer = 50
   Private Const MAX_LENGTH As Integer = 255
   Private CharBar As String
   Private CharSpace As String
   Private CharStart As String
   Private CharEnd As String
   
   Private Sub Class_Initialize()
       ' Save the state of the variables to change
       statusBarState = Application.DisplayStatusBar
       enableEventsState = Application.EnableEvents
       screenUpdatingState = Application.ScreenUpdating
       ' set the progress bar chars (should be equal size)
       CharBar = ChrW(9608)
       CharSpace = ChrW(9617) 'ChrW(12288)
       CharStart = ChrW(9621)
       CharEnd = ChrW(9615)
   
       ' Set the desired state
       Application.DisplayStatusBar = True
   '    Application.ScreenUpdating = False
   '    Application.EnableEvents = False
   End Sub
   
   Private Sub Class_Terminate()
       ' Restore settings
       Application.DisplayStatusBar = statusBarState
       Application.ScreenUpdating = screenUpdatingState
       Application.EnableEvents = enableEventsState
       Application.StatusBar = False
   End Sub
   
   Public Function Update(ByVal Value As Long, _
                     Optional ByVal MaxValue As Long = 0, _
                     Optional ByVal Status As String = "", _
                     Optional ByVal StatusEnd As String = "", _
                     Optional ByVal DisplayPercent As Boolean = True) As String
   
       ' Value          : 0 to 100 (if no max is set)
       ' Value          : >=0 (if max is set)
       ' MaxValue       : >= 0
       ' Status         : optional message to display for user
       ' DisplayPercent : Display the percent complete after the status bar
   
       ' <Status> <Progress Bar> <Percent Complete>
   
       ' Validate entries
       If Value < 0 Or MaxValue < 0 Or (Value > 100 And MaxValue = 0) Then Exit Function
   
       ' If the maximum is set then adjust value to be in the range 0 to 100
       If MaxValue > 0 Then Value = WorksheetFunction.RoundUp((Value * 100) / MaxValue, 0)
   
       ' Message to set the status bar to
       Dim Display As String
       Display = Status & "  " & CharStart
   
       ' Set bars
       Display = Display & String(Int(Value / (100 / NUM_BARS)), CharBar)
       ' set spaces
       Display = Display & String(NUM_BARS - Int(Value / (100 / NUM_BARS)), CharSpace)
   
       ' Closing character to show end of the bar
       Display = Display & CharEnd
   
       If DisplayPercent = True Then Display = Display & "  (" & Value & "%)  "
   
       Display = Display & "  " & StatusEnd
   
       ' chop off to the maximum length if necessary
       If Len(Display) > MAX_LENGTH Then Display = Right(Display, MAX_LENGTH)
   
       Update = Display
       Application.StatusBar = Display
   End Function
   

2. Используйте его следующим образомв вашем уже существующем коде:

   Option Explicit
   
   Sub TestProgressBar()
       Dim Progress As New ProgressBar
   
       Dim i As Long
       For i = 1 To 10
           Progress.Update i, 10, "Some Text before", "SomeTextAfter", True
           Application.Wait (Now + TimeValue("0:00:01"))
       Next i
   End Sub
   

Приведенный выше код является улучшенной версией исходного кода, найденного здесь:
Индикатор выполнения в VBAExcel