スキルアップ・問題解決なら、モーグにおまかせ！

ウィンドウズ上のアプリケーションでは時間のかかる処理が行われるような場合、処理経過状況を知るにはプログレスバーと呼ばれるものが使われることがあります。エクセル固有の機能でプログレスバーを実現する場合、ステータスバーに“■”をいくつも表示させる、ユーザフォームを表示して、ラベルの長さを調節する、などの方法が考えられますが、ここではワークシート上でShapeを使ってプログレスバーを実現する方法を考えます。

（機能）
１．３つのShapeを描画（ProgressBarの土台、色つき、色なし）
２．１で描画した色なしのShapeのWidthを調節して処理の進捗状況を表現
３．処理の終了とShapeの削除

（サンプル）※上記機能を3つのプロシージャとして個別に実現します

'------標準モジュール------
Option Explicit
Private TargetSh As Worksheet
Private TotalValue As Long, PrevValue As Long
Private MyShape As Shape, MyShape2 As Shape, BaseShape As Shape
Private Const W As Double = 280, H As Double = 20


Public Sub BeginProgress(Total As Long, _　　
               Sh As Worksheet, _
               X As Long, _
               Y As Long)'１の機能

    Set TargetSh = Sh　'モジュールレベルで用意した変数に表示対象のシートを設定
    TotalValue = Total　'モジュールレベルで用意した変数に最大値を格納

　　'Shapeの描画
    Set BaseShape = Sh.Shapes.AddShape(msoShapeRectangle, _
                X, Y, W + 20, H + 10)
    Set MyShape = Sh.Shapes.AddShape(msoShapeRectangle, _
                X + 10, Y + 5, W, H)
    Set MyShape2 = Sh.Shapes.AddShape(msoShapeRectangle, _
                X + 10, Y + 5, W, H)
                
    With MyShape　'色つきShapeの設定
    .Fill.Visible = msoTrue
    .Fill.ForeColor.RGB = vbRed
    .Fill.Patterned msoPatternLightVertical
    .Line.Visible = msoFalse
    End With

    MyShape2.Line.Visible = msoFalse　'色なしShapeの設定
    BaseShape.Line.Weight = 5　'土台となるShapeの枠線の太さを指定
    PrevValue = 1'前回値を１とする
End Sub

Public Sub CountUp(Cur As Long)　　'２の機能
    Dim i As Long
    If Cur < PrevValue Then Exit Sub
    For i = PrevValue To Cur
    MyShape2.Width = W - (W / TotalValue * i)
    DoEvents
    Next i
    PrevValue = Cur'前回値を設定
End Sub

Public Sub EndProgress()　　'３の機能
    Call CountUp(TotalValue) 'Totalまで進める

　　'削除
    TargetSh.Shapes.Range(Array _
        (BaseShape.Name, MyShape.Name, MyShape2.Name)) _
        .Delete
    Set TargetSh = Nothing
End Sub

'---テスト用プロシージャ---シート上のコマンドボタンより

Private Sub CommandButton1_Click()
Dim i As Long

'最大値、対象シート、X座標、Y座標を指定してShapeを描画
Call BeginProgress(250, ActiveSheet, 200, 200)

'処理開始　-　セルへの値書き込み
For i = 1 To 250
    ActiveSheet.Cells(i, 1).Value = i
    '現在値を与えて進捗情況を表示
　　Call CountUp(i)
Next i

'プログレスバーを最大値まで進めて削除
Call EndProgress

End Sub

※使い方

BeginProgress（最大値、対象シート、X座標、Y座標）
CountUp（現在値）
EndProgress

上記サンプルは単純なループ構造で収まらない場合を想定して、最大値と現在値を指定できるようにしましたが、CountUpプロシージャでは必ずしも最大値まで進捗させる必要はありません。
ProgressBarの進捗が途中でも、処理が終わった時点でEndProgressを呼び出せば、強制的に最大値まで進めた上でShapeを削除します。