如何在 Excel VBA 中創建進度條？

Question

我正在做一個需要從數據庫更新大量數據的 Excel 應用程序，因此需要時間。 我想在用戶窗體中制作一個進度條，並在數據更新時彈出。 我想要的條只是一個藍色的小條，左右移動並重復直到更新完成，不需要百分比。

我知道我應該使用progressbar控件，但我嘗試了一段時間，但無法做到。

我的問題是progressbar條控件，我看不到進度條。 它只是在表單彈出時完成。 我使用循環和DoEvent但這不起作用。 另外，我希望該過程重復運行，而不僅僅是一次。

Answer 1

有時狀態欄中的一條簡單消息就足夠了：

這很容易實現：

Dim x               As Integer 
Dim MyTimer         As Double 

'Change this loop as needed.
For x = 1 To 50
    ' Do stuff
    Application.StatusBar = "Progress: " & x & " of 50: " & Format(x / 50, "0%")
Next x 

Application.StatusBar = False

Answer 2

這是使用 StatusBar 作為進度條的另一個示例。

通過使用一些 Unicode 字符，您可以模仿進度條。 9608 - 9615 是我為條形嘗試的代碼。 只需根據要在條形之間顯示多少空間來選擇一個。 您可以通過更改 NUM_BARS 來設置條的長度。 此外，通過使用類，您可以將其設置為自動處理初始化和釋放狀態欄。 一旦對象超出范圍，它將自動清理並將狀態欄釋放回 Excel。

' Class Module - 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 BAR_CHAR As String
Private SPACE_CHAR 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)
    BAR_CHAR = ChrW(9608)
    SPACE_CHAR = ChrW(9620)
    ' 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 Sub Update(ByVal Value As Long, _
                  Optional ByVal MaxValue As Long= 0, _
                  Optional ByVal Status As String = "", _
                  Optional ByVal DisplayPercent As Boolean = True)

    ' 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 Sub

    ' 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 & "  "

    ' Set bars
    display = display & String(Int(Value / (100 / NUM_BARS)), BAR_CHAR)
    ' set spaces
    display = display & String(NUM_BARS - Int(Value / (100 / NUM_BARS)), SPACE_CHAR)

    ' Closing character to show end of the bar
    display = display & BAR_CHAR

    If DisplayPercent = True Then display = display & "  (" & Value & "%)  "

    ' chop off to the maximum length if necessary
    If Len(display) > MAX_LENGTH Then display = Right(display, MAX_LENGTH)

    Application.StatusBar = display
End Sub

示例用法：

Dim progressBar As New ProgressBar

For i = 1 To 100
    Call progressBar.Update(i, 100, "My Message Here", True)
    Application.Wait (Now + TimeValue("0:00:01"))
Next

Answer 3

過去，在 VBA 項目中，我使用帶有背景顏色的標簽控件並根據進度調整大小。 可以在以下鏈接中找到一些具有類似方法的示例：

1. http://oreilly.com/pub/h/2607
2. http://www.ehow.com/how_7764247_create-progress-bar-vba.html
3. http://spreadsheetpage.com/index.php/tip/displaying_a_progress_indicator/

這是使用 Excel 的 Autoshapes 的一種：

http://www.andypope.info/vba/pmeter.htm

Answer 4

我喜歡這里發布的所有解決方案，但我使用條件格式作為基於百分比的數據欄解決了這個問題。

這適用於一行單元格，如下所示。 包含 0% 和 100% 的單元格通常是隱藏的，因為它們只是為了提供“ScanProgress”命名范圍（左）上下文。

在代碼中，我在一個表中循環做一些事情。

For intRow = 1 To shData.Range("tblData").Rows.Count

    shData.Range("ScanProgress").Value = intRow / shData.Range("tblData").Rows.Count
    DoEvents

    ' Other processing

Next intRow

最少的代碼，看起來不錯。

Answer 5

============== This code goes in Module1 ============

Sub ShowProgress()
    UserForm1.Show
End Sub

============== Module1 Code Block End =============

在工作表上創建一個按鈕； 將按鈕映射到“ShowProgress”宏

創建一個帶有 2 個按鈕、進度條、條形框、文本框的 UserForm1：

UserForm1 = canvas to hold other 5 elements
CommandButton2 = Run Progress Bar Code; Caption:Run
CommandButton1 = Close UserForm1; Caption:Close
Bar1 (label) = Progress bar graphic; BackColor:Blue
BarBox (label) = Empty box to frame Progress Bar; BackColor:White
Counter (label) = Display the integers used to drive the progress bar

======== Attach the following code to UserForm1 =========

Option Explicit

' This is used to create a delay to prevent memory overflow
' remove after software testing is complete

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub UserForm_Initialize()

    Bar1.Tag = Bar1.Width
    Bar1.Width = 0

End Sub
Sub ProgressBarDemo()
    Dim intIndex As Integer
    Dim sngPercent As Single
    Dim intMax As Integer
    '==============================================
    '====== Bar Length Calculation Start ==========

    '-----------------------------------------------'
    ' This section is where you can use your own    '
    ' variables to increase bar length.             '
    ' Set intMax to your total number of passes     '
    ' to match bar length to code progress.         '
    ' This sample code automatically runs 1 to 100  '
    '-----------------------------------------------'
    intMax = 100
    For intIndex = 1 To intMax
        sngPercent = intIndex / intMax
        Bar1.Width = Int(Bar1.Tag * sngPercent)
        Counter.Caption = intIndex


    '======= Bar Length Calculation End ===========
    '==============================================


DoEvents
        '------------------------
        ' Your production code would go here and cycle
        ' back to pass through the bar length calculation
        ' increasing the bar length on each pass.
        '------------------------

'this is a delay to keep the loop from overrunning memory
'remove after testing is complete
        Sleep 10

    Next

End Sub
Private Sub CommandButton1_Click() 'CLOSE button

Unload Me

End Sub
Private Sub CommandButton2_Click() 'RUN button

        ProgressBarDemo

End Sub

================= UserForm1 Code Block End =====================

============== This code goes in Module1 =============

Sub ShowProgress()
    UserForm1.Show
End Sub

============== Module1 Code Block End =============

Answer 6

我喜歡這個頁面的狀態欄：

https://wellsr.com/vba/2017/excel/vba-application-statusbar-to-mark-progress/

我更新了它，以便它可以用作被調用的過程。 對我沒有信用。

showStatus Current, Total, "  Process Running: "

Private Sub showStatus(Current As Integer, lastrow As Integer, Topic As String)
Dim NumberOfBars As Integer
Dim pctDone As Integer

NumberOfBars = 50
'Application.StatusBar = "[" & Space(NumberOfBars) & "]"


' Display and update Status Bar
    CurrentStatus = Int((Current / lastrow) * NumberOfBars)
    pctDone = Round(CurrentStatus / NumberOfBars * 100, 0)
    Application.StatusBar = Topic & " [" & String(CurrentStatus, "|") & _
                            Space(NumberOfBars - CurrentStatus) & "]" & _
                            " " & pctDone & "% Complete"

' Clear the Status Bar when you're done
'    If Current = Total Then Application.StatusBar = ""

End Sub

Answer 7

您可以在 VBA 中創建一個表單，使用代碼隨着代碼的進展增加標簽控件的寬度。 您可以使用標簽控件的寬度屬性來調整其大小。 您可以將標簽的背景顏色屬性設置為您選擇的任何顏色。 這將讓您創建自己的進度條。

調整大小的標簽控件是一個快速解決方案。 然而，大多數人最終會為他們的每個宏創建單獨的表單。 我使用 DoEvents 函數和一個無模式表單來為您的所有宏使用一個表單。

這是我寫的一篇博客文章： http : //strugglingtoexcel.wordpress.com/2014/03/27/progress-bar-excel-vba/

您所要做的就是將表單和模塊導入到您的項目中，並使用以下命令調用進度條： Call modProgress.ShowProgress(ActionIndex, TotalActions, Title.....)

我希望這有幫助。

Answer 8

Sub ShowProgress()
' Author    : Marecki
  Const x As Long = 150000
  Dim i&, PB$

  For i = 1 To x
    PB = Format(i / x, "00 %")
    Application.StatusBar = "Progress: " & PB & "  >>" & String(Val(PB), Chr(183)) & String(100 - Val(PB), Chr(32)) & "<<"
    Application.StatusBar = "Progress: " & PB & "  " & ChrW$(10111 - Val(PB) / 11)
    Application.StatusBar = "Progress: " & PB & "  " & String(100 - Val(PB), ChrW$(9608))
  Next i

  Application.StatusBar = ""
End SubShowProgress

Answer 9

嗨， Marecki的另一篇文章的修改版。 有4種款式

1. dots ....
2  10 to 1 count down
3. progress bar (default)
4. just percentage.

在你問我為什么不編輯那個帖子之前，我做了並且它被拒絕了被告知要發布一個新的答案。

Sub ShowProgress()

  Const x As Long = 150000
  Dim i&, PB$

  For i = 1 To x
  DoEvents
  UpdateProgress i, x
  Next i

  Application.StatusBar = ""
End Sub 'ShowProgress

Sub UpdateProgress(icurr As Long, imax As Long, Optional istyle As Integer = 3)
    Dim PB$
    PB = Format(icurr / imax, "00 %")
    If istyle = 1 Then ' text dots >>....    <<'
        Application.StatusBar = "Progress: " & PB & "  >>" & String(Val(PB), Chr(183)) & String(100 - Val(PB), Chr(32)) & "<<"
    ElseIf istyle = 2 Then ' 10 to 1 count down  (eight balls style)
        Application.StatusBar = "Progress: " & PB & "  " & ChrW$(10111 - Val(PB) / 11)
    ElseIf istyle = 3 Then ' solid progres bar (default)
        Application.StatusBar = "Progress: " & PB & "  " & String(100 - Val(PB), ChrW$(9608))
    Else ' just 00 %
        Application.StatusBar = "Progress: " & PB
    End If
End Sub

Answer 10

關於用戶窗體中的progressbar控件，如果您不使用repaint事件，它將不會顯示任何進度。 您必須在循環內對此事件進行編碼（並且顯然會增加progressbar值）。

使用示例：

userFormName.repaint

Answer 11

只需將我的部分添加到上述集合中。

如果您追求更少的代碼和可能很酷的 UI。 查看我的GitHub for Progressbar for VBA

一個可定制的：

Dll 是為 MS-Access 考慮的，但應該可以在所有 VBA 平台上工作，只需稍作改動。 還有一個帶有示例的 Excel 文件。 您可以自由擴展 vba 包裝器以滿足您的需要。

該項目目前正在開發中，並未涵蓋所有錯誤。 所以期待一些！

您應該擔心 3rd 方 dll，如果您擔心，請在實施 dll 之前隨意使用任何可信賴的在線防病毒軟件。

Answer 12

還有許多其他很棒的帖子，但是我想說的是，理論上您應該能夠創建一個真正的進度條控件：

1. 使用CreateWindowEx()創建進度條

一個 C++ 示例：

hwndPB = CreateWindowEx(0, PROGRESS_CLASS, (LPTSTR) NULL, WS_CHILD | WS_VISIBLE, rcClient.left,rcClient.bottom - cyVScroll,rcClient.right, cyVScroll,hwndParent, (HMENU) 0, g_hinst, NULL);

hwndParent應該設置為父窗口。 為此，可以使用狀態欄或自定義表單！ 這是從 Spy++ 中找到的 Excel 的窗口結構：

因此，使用FindWindowEx()函數應該相對簡單。

hwndParent = FindWindowEx(Application.hwnd,,"MsoCommandBar","Status Bar")

創建進度條后，您必須使用SendMessage()與進度條交互：

Function MAKELPARAM(ByVal loWord As Integer, ByVal hiWord As Integer)
    Dim lparam As Long
    MAKELPARAM = loWord Or (&H10000 * hiWord)
End Function

SendMessage(hwndPB, PBM_SETRANGE, 0, MAKELPARAM(0, 100))
SendMessage(hwndPB, PBM_SETSTEP, 1, 0)
For i = 1 to 100
    SendMessage(hwndPB, PBM_STEPIT, 0, 0) 
Next
DestroyWindow(hwndPB)

我不確定這個解決方案有多實用，但它可能看起來比這里提到的其他方法更“官方”。

Answer 13

我尋找的不錯的對話框進度欄形式。 來自alainbryden的進度條

使用非常簡單，而且看起來不錯。

編輯：鏈接現在僅適用於高級會員：/

這是一個不錯的替代類。

Answer 14

如果您有大量數據需要處理，@ eykanal發布的解決方案可能不是最好的，因為啟用狀態欄會減慢代碼執行速度。

以下鏈接說明了構建進度條的一種好方法。 適用於高數據量（約250K條記錄+）：

http://www.excel-easy.com/vba/examples/progress-indicator.html

Answer 15

您可以添加一個 Form 並將其命名為 Form1，也可以將一個 Frame 添加為 Frame1 以及 Label1。 將 Frame1 寬度設置為 200，將背景顏色設置為藍色。 將代碼放在模塊中並檢查它是否有幫助。

    Sub Main()
    Dim i As Integer
    Dim response
    Form1.Show vbModeless
    Form1.Frame1.Width = 0
    For i = 10 To 10000
        With Form1
            .Label1.Caption = Round(i / 100, 0) & "%"
            .Frame1.Width = Round(i / 100, 0) * 2
             DoEvents
        End With
    Next i

    Application.Wait Now + 0.0000075

    Unload Form1

    response = MsgBox("100% Done", vbOKOnly)

    End Sub

如果要在狀態欄上顯示，則可以使用其他更簡單的方式：

   Sub Main()
   Dim i As Integer
   Dim response
   For i = 10 To 10000
        Application.StatusBar = Round(i / 100, 0) & "%"
   Next i

   Application.Wait Now + 0.0000075

   response = MsgBox("100% Done", vbOKOnly)

   End Sub

Answer 16

我知道這是一個舊線程，但我問過一個類似的問題，但不知道這個問題。 我需要一個 Excel VBA 進度條並找到此鏈接： Excel Z6E3EC7E6A9F6007B4838FC0EE7 。 這是我寫的一個通用版本。 有 2 種方法，一個簡單版本 DisplaySimpleProgressBarStep，默認為 '[|| ] 20% Complete' 和一個更通用的版本 DisplayProgressBarStep，它包含一個可選 arguments 的洗衣清單，這樣您就可以讓它看起來像您想要的任何東西。

    Option Explicit
    
    ' Resources
    '   ASCII Chart: https://vbaf1.com/ascii-table-chart/
    
    Private Enum LabelPlacement
        None = 0
        Prepend
        Append
    End Enum
    
    #If VBA7 Then
     Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
    #Else
     Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
    #End If
    
    Public Sub Test()
        Call ProgressStatusBar(Last:=10)
    End Sub
    
    Public Sub Test2()
    Const lMilliseconds As Long = 500
    Dim lIndex As Long, lNumberOfBars As Long
    Dim sBarChar As String
        sBarChar = Chr$(133) ' Elipses …
        sBarChar = Chr$(183) ' Middle dot ·
        sBarChar = Chr$(176) ' Degree sign °
        sBarChar = Chr$(171) ' Left double angle «
        sBarChar = Chr$(187) ' Right double angle »
        sBarChar = Chr$(166) ' Broken vertical bar ¦
        sBarChar = Chr$(164) ' Currency sign ¤
        sBarChar = Chr$(139) ' Single left-pointing angle quotation mark ‹
        sBarChar = Chr$(155) ' Single right-pointing angle quotation mark ›
        sBarChar = Chr$(149) ' Bullet •
        sBarChar = "|"
        
        For lIndex = 1 To 10
            Call DisplayProgressBarStep(lIndex, 10, 50, LabelPlacement.Append, sBarChar)
            Call Sleep(lMilliseconds)
        Next
        Call MsgBox("Status bar test completed.", vbOKOnly Or vbInformation, "Test2 Completed")
        Call DisplayProgressBarStep(lIndex, 10, bClearStatusBar:=True)
    End Sub
    
    Public Sub Test2Simple()
    Const lMilliseconds As Long = 500
    Dim lIndex As Long, lNumberOfBars As Long
        For lIndex = 1 To 10
            Call DisplayProgressBarStep(lIndex, 10, 50)
            Call Sleep(lMilliseconds)
        Next
        Call MsgBox("Status bar test completed.", vbOKOnly Or vbInformation, "Test2Simple Completed")
        Call DisplayProgressBarStep(lIndex, 10, bClearStatusBar:=True)
    End Sub
    
    ''' <summary>
    ''' Method to display an Excel ProgressBar. Called once for each step in the calling code process.
    ''' Defaults to vertical bar surrounded by square brackets with a trailing percentage label (e.g. [|||||] 20% Complete).
    '''
    ''' Adapted
    ''' From: Excel VBA StatusBar
    ''' Link: https://www.wallstreetmojo.com/vba-status-bar/
    ''' </summary>
    ''' <param name="Step">The current step count.</param>
    ''' <param name="StepCount">The total number of steps.</param>
    ''' <param name="NumberOfBars">Optional, Number of bars displayed for StepCount. Defaults to StepCount. The higher the number, the longer the string.</param>
    ''' <param name="LabelPlacement">Optional, Can be None, Prepend or Append. Defaults to Append.</param>
    ''' <param name="BarChar">Optional, Character that makes up the horizontal bar. Defaults to | (Pipe).</param>
    ''' <param name="PrependedBoundaryText">Optional, Boundary text prepended to the StatusBar. Defaults to [ (Left square bracket).</param>
    ''' <param name="AppendedBoundaryText">Optional, Boundary text appended to the StatusBar. Defaults to ] (Right square bracket).</param>
    ''' <param name="ClearStatusBar">Optional, True to clear the StatusBar. Defaults to False.</param>
    Private Sub DisplayProgressBarStep( _
        lStep As Long, _
        lStepCount As Long, _
        Optional lNumberOfBars As Long = 0, _
        Optional eLabelPlacement As LabelPlacement = LabelPlacement.Append, _
        Optional sBarChar As String = "|", _
        Optional sPrependedBoundaryText As String = "[", _
        Optional sAppendedBoundaryText As String = "]", _
        Optional bClearStatusBar As Boolean = False _
        )
    Dim lCurrentStatus As Long, lPctComplete As Long
    Dim sBarText As String, sLabel As String, sStatusBarText As String
        If bClearStatusBar Then
            Application.StatusBar = False
            Exit Sub
        End If
        
        If lNumberOfBars = 0 Then
            lNumberOfBars = lStepCount
        End If
        lCurrentStatus = CLng((lStep / lStepCount) * lNumberOfBars)
        lPctComplete = Round(lCurrentStatus / lNumberOfBars * 100, 0)
        sLabel = lPctComplete & "% Complete"
        sBarText = sPrependedBoundaryText & String(lCurrentStatus, sBarChar) & Space$(lNumberOfBars - lCurrentStatus) & sAppendedBoundaryText
        Select Case eLabelPlacement
            Case LabelPlacement.None: sStatusBarText = sBarText
            Case LabelPlacement.Prepend: sStatusBarText = sLabel & " " & sBarText
            Case LabelPlacement.Append: sStatusBarText = sBarText & " " & sLabel
        End Select
        Application.StatusBar = sStatusBarText
        ''Debug.Print "CurStatus:"; lCurrentStatus, "PctComplete:"; lPctComplete, "'"; sStatusBarText; "'"
    End Sub
    
    ''' <summary>
    ''' Method to display a simple Excel ProgressBar made up of vertical bars | with a trailing label. Called once for each step in the calling code process.
    '''
    ''' Adapted
    ''' From: Excel VBA StatusBar
    ''' Link: https://www.wallstreetmojo.com/vba-status-bar/
    ''' </summary>
    ''' <param name="Step">The current step count.</param>
    ''' <param name="StepCount">The total number of steps.</param>
    ''' <param name="NumberOfBars">Optional, Number of bars displayed for StepCount. Defaults to StepCount. The higher the number, the longer the string.</param>
    ''' <param name="ClearStatusBar">Optional, True to clear the StatusBar. Defaults to False.</param>
    Private Sub DisplaySimpleProgressBarStep( _
        lStep As Long, _
        lStepCount As Long, _
        Optional lNumberOfBars As Long = 0, _
        Optional bClearStatusBar As Boolean = False _
        )
        Call DisplayProgressBarStep(lStep, lStepCount, lNumberOfBars, bClearStatusBar:=bClearStatusBar)
    End Sub