Shapeは何個まで可能か

ワークシート上に、いったい何個の Shape を描けるのか。

ひょっとして VBA の Shape にも、似たような制限があるのではないか？　あるとすれば、無限に Shape が Add されていくようなプログラムを能天気に作ると、使い物にならないのではないか？

そこで、調べてみることにしました。
使ったプログラムは、次のようなものです。エラーが出るまで小さな四角形を位置をずらしながら次々に描画していく、というものです。ついでに、描画に要する時間も測定しました。

描画数の上限は、ＰＣの能力など動作環境にも依存するので、決められたものはないようです。ここでの結果は、あくまで筆者の環境でのもので、なおかつ描画ループにカウンターの操作／表示などを含んでいるので、描画時間はその分だけ付加されており、正確なものではありません。だいたいの傾向を知るためのものなので、そのつもりで。

標準モジュール        HowManyShapesAvailable()

Private index
'----- 描画可能個数と描画時間の測定
Public Sub HowManyShapesAvailable()
Dim count, msg, startTime
      deleteShapes
      count = 0: index = 4
      On Error Resume Next
      startTime = Timer
'      Application.ScreenUpdating = False
      Do While Err.Number = 0
            If count Mod 1000 = 0 Then _
                recordTime count, Timer - startTime
            count = count + 1
            ActiveSheet.Shapes.AddShape _
                msoShapeRectangle, 100 + count, 100 + count, 10, 10
            Application.StatusBar = count
            DoEvents
      Loop
'      Application.ScreenUpdating = True
      msg = Err.Number & Err.Description & vbCrLf & _
            "countMax = " & count - 1
      MsgBox msg, vbOKOnly, "終了"
End Sub
'----- Shape をすべて消去する
Private Sub deleteShapes()
Dim shape, count, startTime, processTime
      count = 0
      startTime = Timer
      Application.ScreenUpdating = False
'安直な削除
      ActiveSheet.Shapes.SelectAll
      Selection.Delete
'律儀な削除（こちらの方が圧倒的に速い）
'      For Each shape In ActiveSheet.Shapes
'            count = count + 1: Application.StatusBar = count
'            shape.Delete
'      Next
      processTime = Timer - startTime
      Debug.Print "Delete ProcessTime:" & processTime
      Application.ScreenUpdating = True
End Sub
'----- 途中の経過時間を記録する
Private Sub recordTime(count, processTime)
      With ActiveSheet.Cells(index, 1)
            .Value = count
            .Offset(0, 1).Value = processTime
      End With
      index = index + 1
End Sub

結果

いったい、何個まで描画可能なのかは、わかりませんでした。１２９，０００個まで描画させたのですが、エラーは発生せず、時間はおよそ１５時間を要しました（その時のメモリーの占有量は３GBを超えていました）。それで、ひとまずそこで中断したために、上限は確認できず。とりあえず、C# のコントロールのように、少なくとも１万個というようなオーダーではないことが確認できたことになります。
しかし、１５時間はかかり過ぎですね。実用的とはいえません。

また、個数が増えるにしたがってパフォーマンスは確実に低下していきます。グラフはとりあえず最初の６００００個分について、描画個数とそれに要した時間、一定数の描画を行った後の１個あたりの描画時間を表わしたものです。スクリーンのアップデイトを ON にした場合（青）と OFF にした場合（赤）とを表示しています。１個あたりの描画時間は直線的に上昇していますので、それを積分した累積時間は２次関数的に上昇します。

面白いのは、スクリーンのアップデイトを切っている(OFF)と、切らない場合(ON)と比較して１個あたりの描画時間の上昇が少ないことです。両者の比(OFFの場合/ONの場合）が、最初の１０００個までは 1/10 程度であったものが、６００００個になると 1/40 くらいまで差がついていました。

もうひとつ面白かったのは、Delete に思いのほか時間がかかることです。１００００個の描画を行うのに、スクリーンのアップデイトを切っていた場合には１９秒しかかからなかったのに、同じように上の deleteShapes() を使ってその１００００個を全部（安直に）削除しようとすると、なんと８１４秒を要しました。ここでは、すべて削除するために Activesheet.Shapes.SelectAll を使って端折っていますが、律儀に For Each で削除すると 13.7 秒でした。ちなみに、５０００個だと描画に7.3秒、For Each で消去に5.1秒でした。このあたりのカラクリは、筆者にはよくわかりません。

描画に要する時間（秒）

HowManyShapesAvailable() の実行結果

結論

① なにはともあれ、AddShape の実行時には Application.ScreenUpdating=False としておきましょう。
② Shape の個数は、上限があるわけではありませんが、５０００個くらいで止めておくのが無難です。１００００個になっても描画自体のパフォーマンスはそれほど落ちませんが、削除するのが大変です。当然ながら、全部削除するのに、全部一から描画するのと同等の時間がかかります。
③ Shape をまとめて削除する場合は、For Each shape in Activesheet.Shapes を用いてきちんと削除しましょう。１００００個を SelectAll でまとめて削除しようとすると、消し始めてからコーヒーを自分で沸かして、飲みながら一服し、その後トイレに立って戻ってきて、さらに誰かに電話して世間話をし終わった頃にやっと終了します。

以上は、小さな四角形を多数描画する際のパフォーマンス事例です。他の Shape の場合はどうなるのか、PC のスペックや Excel のバージョンなどの環境によってどう変わるのか、これはいちいちテストしてみるほかはないようです。ただし、後者の環境の違いについては、クライアントの環境にあわせる必要がありますから、高いスペックを前提にしないほうがよいと思います。