Excel VBAで、セルを円状に塗りつぶすことはできますか？

質問

Excelのセルに、近似的な円を描きたいのですが、アルゴリズムが思いつきません。

(1) A1セルには、1マスの長さ（単位：ｍ）が記入されています。例えば「1(ｍ)」。
(2) B1セルには、円の半径（単位：ｍ）が記入されています。例えば「15(ｍ)」。
(3) C1セルには、円の中心になるセルの番地が記入されています。例えば「Y22」。
(4) 以上(1)～(3)は、可変でとっかえひっかえできるようにしたいです。
(5) A2:AX51(50×50マス)の各セルは碁盤の目のように、概ね正方形でになるよう幅・高さを調整してあります。

ここで、macro1を実行したら、Y22番地を中心に半径15ｍの円に最も近い
ライン（セルを黒で塗りつぶし）を描きたいです。

「Y22番地から15ｍの東西南北の4点」だけであれば、AN22、J22、Y37、Y7と手動で
塗りつぶせますが、これら4点以外はルート計算（√）などが絡んでくるのでしょうか？
ピッタリ「Y22番地から15ｍ」というのは不可能ですが、最も15ｍに近似した線で
あればできそうに思うのですが、可能でしょうか？よろしくお願い致します。

回答No.1

takkunnet · ベストアンサー

こんな感じでしょうか？

Option Explicit

Private Sub CommandButton1_Click()

Dim r
Dim a
Dim c_x
Dim c_y
Dim x
Dim y
Dim before_y
Dim now_y

'セルの値取得
a = Range("a1").Value
r = Range("a2").Value
'中心位置を数値で取得
c_x = Range(Range("a3").Value).Column
c_y = Range(Range("a3").Value).Row

before_y = 0

'最左列から最右列まで繰り返し
For x = (c_x - Round(r / a, 0)) To (c_x + Round(r / a, 0))

'中心点から外円の相対位置計算（三平方の定理）
now_y = Round(Sqr(r ^ 2 - (c_x - x) ^ 2), 0)

'前回の位置間での線を補完（最左列～中心 用）
For y = before_y To now_y - 1
Cells(c_y - y, x - 1).Interior.ColorIndex = 1
Cells(c_y + y, x - 1).Interior.ColorIndex = 1
Next

'前回の位置間での線を補完（中心～最右列 用）
For y = now_y + 1 To before_y - 1
Cells(c_y - y, x).Interior.ColorIndex = 1
Cells(c_y + y, x).Interior.ColorIndex = 1
Next

'計算位置に色を付ける
Cells(c_y - now_y, x).Interior.ColorIndex = 1
Cells(c_y + now_y, x).Interior.ColorIndex = 1

'補完時に使用するため前回値として記憶
before_y = now_y

Next

End Sub

ちなみに「Sqr」が√を求める関数です。
急いで作ったので変数が超簡略なため読みにくいソースですが参考になれば幸いです。

お礼

takkunnetさん、貴重なレスありがとうございました！

早速動作確認させていただきましたが完璧でした。
ご教示いただいたロジックでいろいろとやりたい
ことがあるので、応用させていただきます。

しかし、三平方の定理とは懐かしいというか、
思いつきもしませんでした。

今後ともよろしくお願い致します。