【Excel VBA】Excelでドットの円を描く。

　Excelで円を描きたいと思ったことはありませんか？

　挿入 > 図 > 図形 > 円で選択すれば、きれいな円が描けます。（正円は調整してください）

　でも私が描きたいのはそうじゃないんです。ドット絵での円を描きたいのです。

そうそう、こうです！こういうのが描きたいのです。

　というのもMinecraftで円を描きたいのですが、Excelに設計図を描くとMinecraftで出力することができるツールを作ったので、それを活用したいんですね。つまり、「Excelで円を描く」→「マイクラで円が描ける」ということです。

　既にそういうアドオンがあるのかもしれませんけど（多分ある）、自分で作ってみたいので計画します。

Excelで正円を描く

　まずは普通にExcelで円を描いてみましょう。

とりあえず半径10の円を描いてみました。x>0かつy>0の範囲を見てみます。淡い水色の部分は確実に円内ですが、問題は濃い水色の部分です。

　赤で囲まれた範囲を切り取ってみてみると、１マス内に曲線（円）がまたがっています。ここの判別はどうすべきか。

　何も考えずに埋めてしまったり、空けてしまったりすると、不格好な円になってしまいます。

マスに曲線がまたがるとき、どうするか　

　該当マスの多くが円の内側を占めているか、外側を占めているかで区別したいと思います。

　円の内側にするか、外側にするか、面積によって求めるということです。ですので、面積を求めねばなりません。

　[3, 4]の範囲を見てみると、下側９マスは確実に円の内側ですが、一番上のマスは円がまたがっています。この一番上のマスの、円の内側の面積を求めたいというわけです。

　図から分かるように、積分を使って求めようとしたのですが、これがなかなか面倒です。（私の数学力では）簡単な式一つで求められそうにないので、弓形の面積を使って求めようと思います。

弓形の面積を求める

　公式がありそうなものですが、何も考えずに使うのは癪なので、自分で計算してみましょう。

扇形から二等辺三角形を引いた、濃い水色の部分を求めます。半径r、二等辺三角形の高さaを用いて表します。中心角をαとして、弓形の面積は

と表せます。中心角αは

となります。よって、代入することで

という式になります。これをExcel関数で表現すると

=B1^2/2*(2*ACOS(B2/B1)-SIN(2*ACOS(B2/B1)))

となります。（B1がr、B2がaです）

求める面積

　(先ほどの図の扇形)と(a+1の場合の扇形)の差を半分にします。

=B1^2/4*(2*ACOS(B2/B1)-2*ACOS((B2+1)/B1)+SIN(2*ACOS((B2+1)/B1))-SIN(2*ACOS(B2/B1)))

r=10、a=3として面積を求めると、S=9.36242…となります。図から9 < S < 10を満たしています。

　これによって、円がまたがっているマスの判別ができるようになります。

　今回の場合9.3…となっているので、[3, 4]の縦には9マス積まれることになります。

　これをVBAで自動化しましょう。

Excel VBAで、直径からドットの円を描く

　もう少し使いやすく工夫はできますが、とりあえずシンプルに、指定された直径の円をA1セルから描くコードです。

Sub MakeCircle()
   Application.ScreenUpdating = False
   Dim i As Double, ii As Long, d As Long, r As Double, x As Double
   
   d = 29 '直径
   r = d / 2 '半径
   
   If d Mod 2 = 1 Then
       '奇数
       For i = 1 To d
           Cells(r + 0.5, i) = "a"  '上下の境を描く
       Next
       
       For i = r * (-1) To r - 1
       With WorksheetFunction  '縦に積むブロック数
           x = Round(r ^ 2 / 4 * (2 * .Acos(i / r) - 2 * .Acos((i + 1) / r) + Sin(2 * .Acos((i + 1) / r)) - Sin(2 * .Acos(i / r))) - 0.5)
       End With
       
           For ii = r - 0.5 To r - x + 0.5 Step -1
               Cells(ii, i + r + 1) = "a"  '上半円を描く
           Next
           For ii = r + 1.5 To r + x + 0.5
               Cells(ii, i + r + 1) = "a"  '下半円を描く
           Next
       
       Next
       
   Else
       '偶数
       For i = r * (-1) To r - 1
       With WorksheetFunction  '縦に積むブロック数
           x = Round(r ^ 2 / 4 * (2 * .Acos(i / r) - 2 * .Acos((i + 1) / r) + Sin(2 * .Acos((i + 1) / r)) - Sin(2 * .Acos(i / r))))
       End With
           
           For ii = r To r - x + 1 Step -1
               Cells(ii, i + r + 1) = "a"  '上半円を描く
           Next
           For ii = r + 1 To r + x
               Cells(ii, i + r + 1) = "a"  '下半円を描く
           Next
       
       Next
   End If
   
   'Cells(　) = "a"    'セルに"a"を入力
   'Cells(　).Interior.Color = RGB(100, 220, 255) 'セルの背景色を水色に
End Sub

直径dは使用者が変更する想定です。今回はセルに"a"を代入するものですが、背景色を変えたりにもできます。