Excel VBAで塗りつぶしの高速化

前提・実現したいこと

下記のコードの高速化を図りたいです．
現状，実行すると7秒程度で完了しますが，興味本位でExcelでRPGを作ろうと思っており，画面更新の際に逐一7秒かかっていては歩くのもままなりません．
更新の際に変更部分だけ塗りつぶしを変えるように書けば速くはなると思うのですが，様々なパターンが予想される以上，都度全体を更新する方がプログラムとしては書きやすいです．
遅くとも0.5秒くらいには短縮したいところです．
仮に0.5秒としますと，mainの繰り返し処理16×16，FillBoxの繰り返し（塗りつぶし）処理32×32なので1回の塗りつぶし（コメントアウト下）が0.00000191秒（262144回の塗りつぶしを0.5秒）となります．Timerで安定して計測できた呼び出し部（コメントアウト上）で，0.027秒程度でした．全体の実行を0.5秒とするには，この部分を0.002秒程度にする必要があり，FillBoxの処理を10倍程速くしたいです．
高速化の妙案ございますでしょうか？

実行の際の注意

下記コードを実行して頂く場合，シート全体を1ピクセル×1ピクセルにしてからお願い致します．
添付写真のように32×32サイズのドット文字を16×16枚出力しています．

VBA（Excel）
1Option Explicit
2Sub main()
3Application.ScreenUpdating = False
4Dim i As Long
5Dim j As Long
6Dim T As Double
7    For i = 0 To 15
8        For j = 0 To 15
9        T = Timer
10            Call FillBox("あ", "black", Range("B2").Offset(i * 32, j * 32)) '''0.027-0.028秒かかっている
11        Debug.Print Timer - T
12        Next j
13    Next i
14Application.ScreenUpdating = True
15End Sub
16Sub FillBox(str As String, back As String, pos As Range)
17Dim map(31, 31) As Long
18Dim i As Long
19Dim j As Long
20    Select Case back
21        Case "black"
22            For i = 0 To 31
23                For j = 0 To 31
24                    map(j, i) = RGB(0, 0, 0)
25                Next j
26            Next i
27    End Select
28    Select Case str
29        Case "あ"
30            For i = 11 To 13
31                For j = 2 To 6
32                    map(j, i) = RGB(255, 255, 255)
33                Next j
34                For j = 10 To 13
35                    map(j, i) = RGB(255, 255, 255)
36                Next j
37                For j = 20 To 21
38                    map(j, i) = RGB(255, 255, 255)
39                Next j
40                For j = 25 To 26
41                    map(j, i) = RGB(255, 255, 255)
42                Next j
43            Next i
44            For i = 8 To 21
45                For j = 7 To 9
46                    map(j, i) = RGB(255, 255, 255)
47                Next j
48            Next i
49            For i = 17 To 19
50                For j = 12 To 13
51                    map(j, i) = RGB(255, 255, 255)
52                Next j
53                For j = 17 To 21
54                    map(j, i) = RGB(255, 255, 255)
55                Next j
56            Next i
57            For i = 11 To 21
58                For j = 14 To 16
59                    map(j, i) = RGB(255, 255, 255)
60                Next j
61            Next i
62            For i = 8 To 13
63                For j = 17 To 19
64                    map(j, i) = RGB(255, 255, 255)
65                Next j
66            Next i
67            For i = 22 To 24
68                For j = 17 To 26
69                    map(j, i) = RGB(255, 255, 255)
70                Next j
71            Next i
72            For i = 6 To 8
73                For j = 20 To 26
74                    map(j, i) = RGB(255, 255, 255)
75                Next j
76            Next i
77            For i = 11 To 16
78                For j = 22 To 24
79                    map(j, i) = RGB(255, 255, 255)
80                Next j
81            Next i
82            For i = 8 To 10
83                For j = 27 To 29
84                    map(j, i) = RGB(255, 255, 255)
85                Next j
86            Next i
87            For i = 17 To 21
88                For j = 27 To 29
89                    map(j, i) = RGB(255, 255, 255)
90                Next j
91            Next i
92        Case Else
93    End Select
94Dim R As Long
95Dim C As Long
96    For R = 0 To 31
97        For C = 0 To 31
98            pos.Offset(R, C).Interior.Color = map(R, C) '''塗りつぶし1回
99        Next C
100    Next R
101End Sub

参考

こちらのサイト
https://excel.syogyoumujou.com/vba/speed_up.html
で塗りつぶしの高速化が検証されていますが，Test_6のような高速化を上記のコードにも適用可能でしょうか？

環境

プロセッサ：AMD Ryzen 7 3700X 8-Core Processor 3.59 GHz
実装RAM：16.0 GB
OS：Windows 10 Pro
Excelバージョン：2016

行動規範の内容に同意します

回答2件

ベストアンサー

もっと良い方法があるかもしれないですが、
同じパターンのデータを使って良いのであれば、部品として用意しておき、コピー＆ペーストで配置するのが手軽ではないかと思います。
試した所、30倍に高速化することを確認しました。

変更前）約6.1秒
変更後）約0.2秒

■ イメージ

map … 出力先のシート
asset … 部品用のシート

■ コード

vba
1Option Explicit
2
3Sub main()
4    Application.ScreenUpdating = False
5    
6    ' 部品を用意
7    Call InitAsset("asset", 0, "■", "black")
8    Call InitAsset("asset", 1, "あ", "black")
9
10    ' 部品を選択    
11    Call SelectAsset("asset", 1)
12    
13    Worksheets("map").Activate
14    
15    Dim i As Long
16    Dim j As Long
17    Dim T As Double
18    
19    T = Timer
20    For i = 0 To 15
21        For j = 0 To 15
22            ' 部品をペーストで配置
23            Range("B2").Offset(i * 32, j * 32).PasteSpecial
24        Next
25    Next
26    Debug.Print Timer - T
27    
28    Application.ScreenUpdating = True
29End Sub
30
31Sub InitAsset(sheetName As String, index As Long, str As String, back As String)
32    Dim pos
33    Set pos = Worksheets(sheetName).Range("A1").Offset(0, index * 32)
34    
35    Dim map(31, 31) As Long
36    Dim i           As Long
37    Dim j           As Long
38    Select Case back
39        Case "black"
40            For i = 0 To 31
41                For j = 0 To 31
42                    map(j, i) = RGB(0, 0, 0)
43                Next j
44            Next i
45    End Select
46    
47    Select Case str
48        Case "あ"
49            For i = 11 To 13
50                For j = 2 To 6
51                    map(j, i) = RGB(255, 255, 255)
52                Next j
53                For j = 10 To 13
54                    map(j, i) = RGB(255, 255, 255)
55                Next j
56                For j = 20 To 21
57                    map(j, i) = RGB(255, 255, 255)
58                Next j
59                For j = 25 To 26
60                    map(j, i) = RGB(255, 255, 255)
61                Next j
62            Next i
63            For i = 8 To 21
64                For j = 7 To 9
65                    map(j, i) = RGB(255, 255, 255)
66                Next j
67            Next i
68            For i = 17 To 19
69                For j = 12 To 13
70                    map(j, i) = RGB(255, 255, 255)
71                Next j
72                For j = 17 To 21
73                    map(j, i) = RGB(255, 255, 255)
74                Next j
75            Next i
76            For i = 11 To 21
77                For j = 14 To 16
78                    map(j, i) = RGB(255, 255, 255)
79                Next j
80            Next i
81            For i = 8 To 13
82                For j = 17 To 19
83                    map(j, i) = RGB(255, 255, 255)
84                Next j
85            Next i
86            For i = 22 To 24
87                For j = 17 To 26
88                    map(j, i) = RGB(255, 255, 255)
89                Next j
90            Next i
91            For i = 6 To 8
92                For j = 20 To 26
93                    map(j, i) = RGB(255, 255, 255)
94                Next j
95            Next i
96            For i = 11 To 16
97                For j = 22 To 24
98                    map(j, i) = RGB(255, 255, 255)
99                Next j
100            Next i
101            For i = 8 To 10
102                For j = 27 To 29
103                    map(j, i) = RGB(255, 255, 255)
104                Next j
105            Next i
106            For i = 17 To 21
107                For j = 27 To 29
108                    map(j, i) = RGB(255, 255, 255)
109                Next j
110            Next i
111        Case Else
112    End Select
113    Dim R           As Long
114    Dim C           As Long
115    For R = 0 To 31
116        For C = 0 To 31
117            pos.Offset(R, C).Interior.Color = map(R, C)        '''塗りつぶし1回
118        Next C
119    Next R
120End Sub
121
122Sub SelectAsset(sheetName As String, index As Long)
123    Worksheets(sheetName).Activate
124    Range(Cells(1, index * 32 + 1), Cells(32, index * 32 + 32)).Copy
125End Sub

投稿2022/01/19 17:12

編集2022/01/20 05:52

cx20

総合スコア4693

zzzTKG

2022/01/20 14:51

32×32が既に塗られているので当然速くなりますね．アセットは一般的なゲーム開発でも使われるのに思いつきませんでした... 32×32の単体だけでなく，フレームなどの組み合わせパーツなども作ってしまえば高速化に加えてコードの単純化もできそうです．目から鱗でした．ありがとうございます．

cx20

2022/01/20 14:55

> アセットは一般的なゲーム開発でも使われるそうですね。この手の方法はマップタイルとか呼ばれたりするようです。 ■ マップタイルの仕組み | RPGツクールVX Ace 初心者向け講座 https://tkool.jp/products/rpgvxace/lecture/002_004/index.html

行動規範の内容に同意します