ステータスバーに進行状況を表示させる。
ステータスバーを利用してプログレスバーのような処理の進捗状況を表示させます。
VBAでステータスバーの表示を変更するにはApplicationオブジェクトのStatusBarプロパティを変更することでできます。
サンプルコードは２種類の処理を記載しており、１つ目（「進捗状況表示」）は単純にループ処理でステータスバーの表示を更新して進捗状況が進んでいるように処理をしています。
２つ目のサンプルコード（「複数処理の進捗状況表示」）では複数の処理を処理ごとに指定した比率に応じて進捗表示できる範囲を変更できるようにしています。
サンプルコードには処理を３つ設定し、それぞれに50%、20%、30%とそれぞれ進捗表示させる割合を指定しています。
処理1を例にすると処理１が100%終わった時点で、全体の進捗表示の50%分を利用するといった処理になっています。
●進捗状況表示
'******************************************************************
' ステータスバーに進捗状況を表示
'******************************************************************
Sub setProgressBar()
'ステータスバーが非表示なら表示
If Not Application.DisplayStatusBar Then
Application.DisplayStatusBar = True
End If
'表示の初期化
Application.StatusBar = False
'表示メッセージ
Dim sStMsg As String
sStMsg = "ステータスバーをプログレスバーに見立てる:"
Dim i As Long
For i = 1 To 7
'進捗表示に■を利用
sStMsg = sStMsg + "■"
'ステータスバーに設定
Application.StatusBar = sStMsg
'1秒間のウェイト処理
Application.Wait Now + TimeValue("00:00:01")
Next
Application.StatusBar = sStMsg & "（処理完了）"
End Sub■実行結果
●複数処理の進捗状況表示
#If VBA7 And Win64 Then
Private Declare PtrSafe Sub Sleep Lib "KERNEL32.dll" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "KERNEL32.dll" (ByVal dwMilliseconds As Long)
#End If
'******************************************************************
' ステータスバーに進捗状況を表示
' ※複数処理向けの進捗表示
' 処理ごとに進捗表示を変更の割合を変更
'******************************************************************
Sub setProgressbar_EachJob()
'画面描画停止
Application.ScreenUpdating = False
'初期処理
Call InitStatusBar
Dim lCof As Double '処理単位の進捗係数
Dim lProgressJob As Long '処理単位の進捗割合
Dim lProgressAll As Long '全体の進捗割合
Dim lStBarCnt As Long 'ループ処理のカウンタ兼割合計算用
Dim lProgInherit As Long '全体の進捗割合（引継ぎ用）
Dim sProgressBar As String '進捗表示用
'進捗表示に利用する記号など
Dim sBarSymbol As String
Dim sBarSymbolRest As String
Dim lMaxSymbolCnt As Long
sBarSymbol = "◆"
sBarSymbolRest = "◇"
lMaxSymbolCnt = 20 '記号が20個で100%となるようにする
Dim sPreStr As String
Dim sSufStr As String
sPreStr = "処理中… "
sSufStr = "%完了"
'各処理ごとに割り当てる比率を指定
' ※合計が100になるように設定してください。
' このサンプルではジョブを3つの分類に分けて実行しています。
Dim lJobRatio(2) As Long
lJobRatio(0) = 50 '処理1で進捗表示の50%分を利用
lJobRatio(1) = 20 '処理2で進捗表示の30%分を利用
lJobRatio(2) = 30 '処理3で進捗表示の20%分を利用
'■処理1 ※この処理で進捗表示の50%分を利用させる
'------------------------------------------------------------------------
Dim lProgRate As Long
Dim sJobStr As String
lProgRate = lJobRatio(0)
sJobStr = "コピー処理"
'処理単位の進捗係数(ループ終了時にループ回数*係数で処理ごと進捗を100%にするため）
lCof = 1 / (1 * (lProgRate / 100))
'進捗表示
For lStBarCnt = 1 To lProgRate
'処理ごとの進捗の割合
lProgressJob = lStBarCnt * lCof
'全体進捗の割合
lProgressAll = lStBarCnt
'進捗表示設定（lMaxSymbolCntに指定した数の記号をメーターとして利用）
sProgressBar = String(((lProgressAll) / 100) * lMaxSymbolCnt, sBarSymbol)
sProgressBar = sProgressBar + String(lMaxSymbolCnt - Len(sProgressBar), sBarSymbolRest)
'ステータスバー更新
Application.StatusBar = sPreStr & Format(lProgressAll, "#000") & sSufStr & _
"(" & sJobStr & Format(lProgressJob, "#000") & sSufStr & ")" & _
sProgressBar
'ファイルコピー（ダミー）
Call doFileCopy
Next
'全体進捗の割合を次処理に引き継ぐ
lProgInherit = lProgressAll
'■処理2 ※この処理で進捗表示の30%分を利用させる
'------------------------------------------------------------------------
lProgRate = lJobRatio(1)
sJobStr = "移動処理"
'処理単位の進捗係数(ループ終了時にループ回数*係数で処理ごと進捗を100%にするため）
lCof = 1 / (1 * (lProgRate / 100))
'進捗表示
For lStBarCnt = 1 To lProgRate
'処理ごとの進捗の割合
lProgressJob = lStBarCnt * lCof
'全体進捗の割合
lProgressAll = lProgInherit + lStBarCnt '前処理の進捗率を加算
'進捗表示設定（lMaxSymbolCntに指定した数の記号をメーターとして利用）
sProgressBar = String(((lProgressAll) / 100) * lMaxSymbolCnt, sBarSymbol)
sProgressBar = sProgressBar + String(lMaxSymbolCnt - Len(sProgressBar), sBarSymbolRest)
'ステータスバー更新
Application.StatusBar = sPreStr & Format(lProgressAll, "#000") & sSufStr & _
"(" & sJobStr & Format(lProgressJob, "#000") & sSufStr & ")" & _
sProgressBar
'ファイル移動（ダミー）
Call doFileMove
Next
'全体進捗の割合を次処理に引き継ぐ
lProgInherit = lProgressAll
'■処理3 ※この処理で進捗表示の20%分を利用させる
'------------------------------------------------------------------------
lProgRate = lJobRatio(2)
sJobStr = "削除処理"
'処理単位の進捗係数(ループ終了時にループ回数*係数で処理ごと進捗を100%にするため）
lCof = 1 / (1 * (lProgRate / 100))
'進捗表示
For lStBarCnt = 1 To lProgRate
'処理ごとの進捗の割合
lProgressJob = lStBarCnt * lCof
'全体進捗の割合
lProgressAll = lProgInherit + lStBarCnt '前処理の進捗率を加算
'進捗表示設定（lMaxSymbolCntに指定した数の記号をメーターとして利用）
sProgressBar = String(((lProgressAll) / 100) * lMaxSymbolCnt, sBarSymbol)
sProgressBar = sProgressBar + String(lMaxSymbolCnt - Len(sProgressBar), sBarSymbolRest)
'ステータスバー更新
Application.StatusBar = sPreStr & Format(lProgressAll, "#000") & sSufStr & _
"(" & sJobStr & Format(lProgressJob, "#000") & sSufStr & ")" & _
sProgressBar
'ファイル削除（ダミー）
Call doFileDelete
Next
Application.StatusBar = "■処理完了■"
'画面描画再開
Application.ScreenUpdating = True
End Sub
'******************************************************************
' ステータスバーの初期設定
'******************************************************************
Sub InitStatusBar()
'ステータスバーが非表示なら表示
If Not Application.DisplayStatusBar Then: Application.DisplayStatusBar = True
'表示の初期化
Application.StatusBar = False
End Sub
'******************************************************************
' コピー処理（ダミー）
'******************************************************************
'ダミー処理（100ミリ秒のスリープ）
Sub doFileCopy(): Sleep 100: DoEvents: End Sub
'******************************************************************
' 移動処理（ダミー）
'******************************************************************
'ダミー処理（80ミリ秒のスリープ）
Sub doFileMove(): Sleep 80: DoEvents: End Sub
'******************************************************************
' 削除処理（ダミー）
'******************************************************************
'ダミー処理（80ミリ秒のスリープ）
Sub doFileDelete(): Sleep 80: DoEvents: End Sub
■実行結果
