【Excel VBA】進捗表示にプログレスバー設置でストレス軽減

VBAで時間のかかる処理を実行させる場合、待っている時間はかなりストレスがかかります
それは何故でしょうか? はい、それは今どのくらい処理が進んでいるのかが見えないからです!
この記事では、それを解決する方法について提示していきたいと思います

進捗状況を示す方法として思いつく代表的な方法は次の二つだと思います
1.ステータスバーを使って進捗状況を簡易表示する
2.プログレスバーで進捗状況をビジュアルで表示する

1のステータスバーを使う方法は、簡単で利用しやすいけど見栄えが地味
2のプログレスバーは、設置にはひと手間かかるけどビジュアル的でアピール度が高い
 今、「ちゃんと仕事してます!」的な他の人へのアピールもできてストレス軽減になる!

ということで、今回は、2の「プログレスバー」を使った方法を採用して設置方法などについて書いていきます

プログレスバーでVBAの進捗状況をビジュアル化してストレスを軽減しよう!

・ユーザーフォーム作成方法についての記事はこの下のカードから参照できます

プログレスバーはユーザーフォームを使って表示します

・VBE(Visual Basic Editer)で新規UserFormを設置します
・ProgressBarを設置(配置)する方法を解説します
・処理件数を表示するためにラベル(Label)を配置します
・途中で中断できるように、Cancelボタンを配置しておきます

UserFormの設置します

VBE(Visual Basic Editer)で新規UserFormを設置します

ProgressBarを配置します

プログレスバーコントロールは今までに設置したことがない場合は、コントロールボックス内に表示されていません。その場合以下の手順で追加する必要があります

プログレスバー設置手順
  • ユーザーフォーム画面から「ツールボックス」を表示させ、「ツールボックス」上で右クリックします
  • すると「コントロールの追加」ダイアログが表示され、追加できるコントロールが一覧で表示されます
  • 「MicrosoftProgressbarControl 」にチェックを付けて「OK」をクリック
  • 「ツールボックス」にプログレスバーが追加されます

・ツールボックスにProgressBarが追加されているので、以下のようにフォームへ配置します
・オブジェクト名はデフォルトのProgressBar1のままでOKです

ラベルとボタンを配置します

進捗状況の数値を表示するレベルと処理を中断できるようにするためのキャンセルボタンを設置

・コマンドボタンのCaptionは「キャンセル」とします
・オブジェクト名はデフォルトのままでOKです

動かすためのVBAコードの設定方法を解説

UserForm自体に記述するコード部分

プログレスバーを設置したフォームに追加するコードは以下のとおりです

'Cancel判定用フラグ
Public blCancel As Boolean

'Cancelボタンクリック時
Private Sub CommandButton1_Click()
    'Cancel判定用フラグをTrueに
    blCancel = True
End Sub

'Form起動時
Private Sub UserForm_Initialize()
    'CancelフラグをFalseに初期化
    blCancel = False
End Sub

・コードの説明はコード内コメントのとおりです

プログレスバー表示コードを実装してみました

前回の記事で使ったコードにプログレスバー表示を追加したコードがこちらです

・重い処理のループ開始前に前半部分のコードを追加しています
・ループ途中に進行状況の表示を変更するためのコードを追加しています
・ループ終了後にUserFormを消す処理と結果を表示する処理を追加しています

Option Explicit
'貼付け元シート上で開始すること
'プログレスバー設置
Sub Array_match()
    Dim workSh As Worksheet, prefSh As Worksheet
    Dim sName As String
    Set prefSh = ThisWorkbook.ActiveSheet
    sName = prefSh.Range("K1").Value    '取得データ貼付け先シート名
    Set workSh = ThisWorkbook.Worksheets(sName)
    Dim ptCol As Long, pFlgCol As Long
    Dim pMCol As Long, pCol() As Long
    Dim wtCol As Long, wFlgCol As Long
    Dim wMCol As Long, wCol() As Long
    Dim pRow As Long, wRow As Long
    Dim i As Long
    Dim percent As Long
    
    '▼マーク(ターゲット)列を検索
    ptCol = Application.WorksheetFunction.Match("▼", prefSh.Rows(2), 0)
    wtCol = Application.WorksheetFunction.Match("▼", workSh.Rows(2), 0)
    '設定行の最大数
    pMCol = Application.WorksheetFunction.Max(prefSh.Rows(2))
    wMCol = Application.WorksheetFunction.Max(workSh.Rows(2))
    'データ開始列の設定
    pRow = prefSh.Range("G1")
    wRow = workSh.Range("G1")
    '設定の不整合を判定する処理
    If pMCol <> wMCol Then
        MsgBox "引き当てる列の数が不整合のため中止します!"
        Exit Sub
    End If
    ReDim pCol(1 To pMCol)  '指定列を代入する
    pFlgCol = 0 '指定列の配置が連続しているかどうか調べる「0」は連続
    For i = 1 To pMCol
        pCol(i) = Application.WorksheetFunction.Match(i, prefSh.Rows(2), 0)
        If i > 1 Then
            If pCol(i) <> pCol(i - 1) + 1 Then pFlgCol = 1 '連続していない場合「1」
        End If
    Next
    ReDim wCol(1 To wMCol)  '貼付け先も同様に調べる
    wFlgCol = 0
    For i = 1 To wMCol
        wCol(i) = Application.WorksheetFunction.Match(i, workSh.Rows(2), 0)
        If i > 1 Then
            If wCol(i) <> wCol(i - 1) + 1 Then wFlgCol = 1 '連続していない場合「1」
        End If
    Next
    Dim workShEndR As Long, prefShEndR As Long
    Dim tgetTmpR As Long, tmpStr As Variant '文字列の場合もあるのでVariantで
    '最終行取得
    workShEndR = workSh.Cells(Rows.Count, wtCol).End(xlUp).Row
    prefShEndR = prefSh.Cells(Rows.Count, ptCol).End(xlUp).Row
    Dim tgetRng As Range
    'ターゲット(ID)の列範囲をセット
    Set tgetRng = Range(prefSh.Cells(pRow, ptCol), prefSh.Cells(prefShEndR, ptCol))
    Dim matchRng As Variant
    Dim MyArray() As Variant
'/////プログレスバー用/////
    Dim lngHcount As Long 'HIT件数カウント用
    Dim starttime As Single
    Dim myspeed As Single
    starttime = Time
    With UserForm1
        .Show vbModeless                'Modelessで表示
        .ProgressBar1.Min = 1           '最小値
        .ProgressBar1.Max = workShEndR  '最大値
        .ProgressBar1.Value = 1         'プログレスバーの初期値
    End With
    Application.Cursor = xlWait         'マウスカーソルを待機中に
    
    Call マクロ開始

    'オートフィルタが設定されていたら解除する
    If (workSh.AutoFilterMode = True) Then workSh.Rows(wRow - 1).AutoFilter
    lngHcount = 0 'ヒット数カウントを初期化
    '開始件数チェック
    If IsNumeric(Range("N1").Value) = True Then
        If Range("N1").Value > wRow Then wRow = Range("N1").Value
    End If
    
    'ターゲットID件数分のループ
    For tgetTmpR = wRow To workShEndR '4 To workShEndR
        DoEvents    '途中で中断ができるように
        tmpStr = workSh.Cells(tgetTmpR, wtCol).Value '検索対象ID
        '発見できなかった場合エラーとなりマクロが停止するので制御する
        On Error Resume Next
        '対象IDコードを配列から検索
        matchRng = Application.WorksheetFunction.Match(tmpStr, tgetRng, 0)
        If Err <> 0 Then
            matchRng = "" 'ERRORの場合空白に
            Err.Clear
        End If
        If matchRng = "" Then
            '何もしない
        Else
            matchRng = matchRng + wRow - 1 '開始行分をプラスする-1
            '配列のメモリ領域割り当て
            ReDim MyArray(1 To pMCol)
            If pFlgCol = 1 Then '不連続の場合はループ、連続の場合は一括書込み
                For i = 1 To pMCol
                    MyArray(i) = prefSh.Cells(matchRng, pCol(i)).Value
                Next
            Else
                MyArray() = prefSh.Range(prefSh.Cells(matchRng, pCol(1)), _
                                prefSh.Cells(matchRng, pCol(pMCol))).Value
            End If
            If wFlgCol = 1 Then '不連続の場合はループ、連続の場合は一括書込み
                For i = 1 To wMCol
                    workSh.Cells(tgetTmpR, wCol(i)).Value = MyArray(i)
                Next
            Else
                workSh.Range(workSh.Cells(tgetTmpR, wCol(1)), _
                        workSh.Cells(tgetTmpR, wCol(pMCol))) = MyArray
            End If
            lngHcount = lngHcount + 1
            Erase MyArray
        End If
        '/////プログレスバー'キャンセルボタン処理/////
        If UserForm1.blCancel = True Then
            Unload UserForm1                'Formを閉じる
            Application.Cursor = xlDefault  'マウスカーソルを戻す
            MsgBox "処理を中断しました。"
            Call マクロ終了
            End
        End If
        'プログレスバーの値表示を更新
        With UserForm1
            If .ProgressBar1.Min < tgetTmpR And _
                .ProgressBar1.Max >= tgetTmpR Then
                'プログレスバーのLabel表示を更新
                percent = CInt(tgetTmpR / workShEndR * 100)
                .Label1.Caption = percent & "%完了【処理件数: " & _
                                tgetTmpR & " / " & workShEndR & " 】" & _
                                "【HIT件数:" & lngHcount & "件】"
                'プログレスバーの値を更新
                .ProgressBar1.Value = tgetTmpR
            End If
        End With
        DoEvents
    Next
    
    Call マクロ終了
    
    myspeed = Time - starttime      '現在-スタート時刻
    Unload UserForm1                'Formを閉じる
    Application.Cursor = xlDefault  'マウスカーソルを戻す
    
    MsgBox "引当て入力が完了しました!" & _
            "処理時間は" & Minute(myspeed) & "分" & _
            Second(myspeed) & "秒 でした" & vbCrLf & _
            "【データ更新件数は: " & lngHcount & " 件でした】", _
            vbInformation, "処理終了メッセージ"
End Sub

・ループ開始時と処理終了時に「Time」を計測し、その差で処理時間を計測しています
・UserFormのラベルには、処理件数とHIT件数(検索の結果該当した件数を表示
・終了メッセージに処理にかかった時間と処理結果を表示するように変更しています
・キャンセルした場合、その場所から再実行できるように変更しています
【N1セルに開始行数を入力して実行すれば中断したところから再スタートできます】

実際に動かしてみた感想と「まとめ」

実装後に動かしてみた感想

・フォームでのプログレスバー表示を行うと、処理速度は若干落ちてしまいますが
処理遅延はほんの僅かです。表示した方が大幅にストレス軽減効果があると思います
・やむを得ず中断した場合でも、中断したところから再実行できるよう変更して良かった
・プログレスバーの動きを見て進捗が確認できるから、他の作業がやりやすくなった

気づき

VBA実行処理中に別のExcelファイルを開こうとしても開けない
ExcelはVBAが動いている間は、他の作業(Excelでの)ができない
別プロセスでExcelを起動させておけば作業可能になる

今回の処理の流れは

・プログレスバーを設置するにはUserFormを用意します
・初期のツールボックスにはプログレスバーコントロールがないので追加する必要がある
・ラベルとコマンドボタンを配置したらUserFormのコードを表示してコードを入力
・プログレスバーのコードは重いループ処理の開始前に初期化し表示させ
・1つのループ処理が終わったタイミングでプログレスバーの表示を動かしていきます
・同時に、ラベルに処理件数等を表示させていきます
【今後の機能追加など…】
・長時間かかるVBA実行中にPCが休止状態やスリープになった場合、VBAも中断してしまいます
 「終わっていると思ったら中断されていた」なんてことがないように対策を検討していきます
・実行中は、Excelで他の作業を行うことができません(別プロセス起動方法を検討)
・高速化した「VlookUp関数」のVBAでの活用法を再検討してみたいと思います
次回はこれらのどれかをクリアする対策を提示していきます  ご期待ください(^^)/

サンプルファイルをダウンロードできます(下記リンク先へ)

記事で使用したサンプルファイルがダウンロードできるページを設置しています
こちら(このリンク先)からご利用ください