思い立った背景

ExcelVBAでそこそこデータ数の多いcsvファイルなどを繰り返し読み込んでいる際に、今処理してますよ！というダイアログを表示したい。
単に処理中という事を示せば十分役割は果たせるが、できれば動かしてオシャレにしたい。
~~負荷が増える？知らんな・・・~~

環境

Windows 10
Excel 2016

方法

ExcelVBAで何らかの作業をしていることを示す方法は色々あります。

ステータスバーに情報を表示
フォームを使って情報を表示
メッセージボックスを使って情報を表示

今回の方法はフォームを使って実装しますが、ステータスバーでも同じようなことができます。
各々好きな方法で実装しましょう。

下準備

まずはVBAを開いて、ユーザフォームを作ります。
何でもいいので適当なサイズでフォームを作成し、Labelという名称のラベルを作ります。
LabelのcaptionにはNow Loadingを設定しておきます。

標準モジュールを作成する

任意の標準モジュールを作成し、次のコードを入力します。

Private Sub main()

   UserForm1.Show vbModeless

   Dim f As Boolean ' ラベルを移動させる向き(true=下、false=上)
   Dim i As Long    ' 繰り返し用変数
   Dim t            ' 時間格納用変数
   Dim update       ' 描画更新頻度

   t = Timer ' 現在の時刻を保管
   f = False ' 初期は上に移動させる
   update = 1000 ' 描画更新頻度(繰り返しn回で画面を更新)

   ' 100000000回繰り返す
   For i = 0 To 100000000
     ' 1000回繰り返したら実行する
     If i Mod update = 0 Then
         DoEvents ' 画面を更新
         f = GetMoveFlag(f) ' 現在の位置から見て上に移動するか下に移動するかを取得
         Call MoveLabel(f) ' Labelを動かす
     End If
   Next i

   ' 処理にかかった時間を表示する(処理完了時の時間 - 処理開始時の時間)
   MsgBox Timer - T & "秒"
End Sub

' 移動方向を返す関数
Private Function GetMoveFlag(f As Boolean) As Boolean
   Dim y As Long      ' 現時点のラベル位置を保管
   Dim max_y As Long  ' フォームの縦幅を保管

   max_y = UserForm1.height
   y = UserForm1.Label.Top

   ' 現時点の方向を保管
   GetMoveFlag = f

   ' フォーム画面縦幅の下側をオーバーフローしたら
   If y >= max_y Then
     GetMoveFlag = False '上に動くようにする

   ' フォーム画面縦幅の上側をオーバーフローしたら
   ElseIf y <= 0 Then
     GetMoveFlag = True '下に動くようにする

   End If

End Function

'ラベルを動かす
Private Sub MoveLabel(f As Boolean)
     If f = True Then ' Trueの時は下に動かす
       UserForm1.Label.Top = UserForm1.Label.Top + 0.1
     Else ' Falseの時は上に動かす
       UserForm1.Label.Top = UserForm1.Label.Top - 0.1
     End If
End Sub

mainを実行すると、フォームの中で上下に動くNow Loading...君を見ることができます。

実行条件と速度の比較

繰り返し回数10000000回

描画更新頻度	実行時間	アニメーション感
1000回に1回	53.234秒	カクカクするが早い
10000回に1回	11.952秒	↑
100000回に1回	7.368秒	↓
1000000回に1回	6.375秒	ゆっくりだが滑らか

当たり前のことではありますが、描画更新頻度が高ければ高いほど動作負荷は大きくなりますので、現実的に使えるのは30fps程度(1秒間に行える繰り返し回数に対して30回程度の描画更新)かなと思いました。

1秒当たりの繰り返し回数を自動計算し、30fps程度になるよう描画更新頻度をダイナミックに設定する方法もできそうな気がしなくもないのですが、その計算で余計に処理が遅くなってしまいますので処理時間を気にする方にはあまり向いていないかもしれません。

まとめ

当初の目論見通り、フォームの中でNow Loadning...を動かすことができました。
上下に同じスピードで動くのがダサ味MAXです。
これなら点滅するとか、そういう方が処理も早いしいいかもしれません。
繰り返しの中でしか動作させられないので、それ以外には使えないのも汎用性に欠けます。
繰り返し速度によって移動スピードが変わるのもあんまりいけてないですね。
ただ、処理してる感は出せるので上手く活用すればいろいろなことに応用できるかもしれません。

おまけ

もう少し動きをつけてみました。

まずは下記を追加してください。

Private Function GetMoveFlag2(f As Boolean) As Boolean
   Dim y As Long
   Dim max_y As Long

   GetMoveFlag2 = f

   max_y = UserForm1.height
   y = UserForm1.Label.Top

   ' 下方向をオーバーフローしたら
   If y >= max_y - 60 Then
     GetMoveFlag2 = False

   ' 上方向をオーバーフローしたら
   ElseIf y <= 30 Then
     GetMoveFlag2 = True

   End If

End Function

Private Sub MoveLabel2(f As Boolean)
     Dim y As Double
     Dim max_y As Double
     Dim center As Double
     Dim h As Double

     max_y = UserForm1.height
     y = UserForm1.Label.Top

     center = max_y / 2 ' フォームサイズ÷2で真ん中を出す

     ' 下方向に移動
     If f = True Then
         If UserForm1.Label.Top <= center Then
             h = (UserForm1.Label.Top) / (center + 60)
         Else
             h = (center - 60) / (UserForm1.Label.Top)
         End If

         UserForm1.Label.Top = UserForm1.Label.Top + h
     Else
         If UserForm1.Label.Top >= center Then
             h = (center - 60) / (UserForm1.Label.Top)
         Else
             h = (UserForm1.Label.Top) / (center + 60)
         End If

         UserForm1.Label.Top = UserForm1.Label.Top - h
     End If

End Sub

その後、下記を書き換えます。

Private Sub main()

   UserForm1.Show vbModeless

   Dim f As Boolean
   Dim i As Long
   Dim T
   T = Timer

   f = False

   Dim A
   A = 0
   For i = 0 To 100000000
     If i Mod 50000 = 0 Then
         DoEvents
         'f = GetMoveFlag(f)←コメントアウト
         f = GetMoveFlag2(f)

         'Call MoveLabel(f)←コメントアウト
         Call MoveLabel2(f)
     End If
   Next i
   MsgBox Timer - T & "秒"

End Sub

上端・下端に近づくにつれてスピードが遅くなるようにしてみました。

文字が波打つような動きにしたければ、ラベルを文字ごとに分けて動くタイミングを分けてやれば実装できると思います。

うまくやれば、跳ねる動きも作れるので興味があればどうぞ(なお、オススメはしません)