円の内側で円を転がす　～ｎ個の円に対応（式の一般化）～

先日から、Excelでスピログラフを作成している。
infoment.hatenablog.com
今日も、前回の続きから。
f:id:Infoment:20211010095409p:plain
前回は、三つの小さな円を同時に回転させてみた。作ってみると、円が一つ
増えるたびに

変数宣言　6回
変数の再宣言（Redim）　6回
変数の計算　6回
計算結果を配列にセット　6回

ということで、「：」で複数行をつながなければ、コードが24行増えることが
分かった。円が増えるたびに変数を増やすのも、それをどう計算するか考える
のも大変なので、式を一般化してみた。

Sub 複数ぐるぐる()

    Dim π As Double
        π = WorksheetFunction.Pi
    
    Dim r(1 To 3) As Long
    ' 大きな円の半径。
        r(1) = 13
    ' 小さな円の半径。
        r(2) = 7
    ' 小さな円の中心からのオフセット量。
        r(3) = 4
    
    ' ※r(1)とr(2)の最小公倍数÷r(1) ← 小さな円を何周回すか。
    ' RoundNumberの略。
    Dim rn As Long
        rn = WorksheetFunction.Lcm(r(1), r(2)) / r(1)
    
    ' 大きな円の中心座標。
    Dim ox1 As Double
    Dim oy1 As Double
        ox1 = 0: oy1 = 0
        
    ' 円周の分割数（Division Count）。
    Dim dc As Double
        dc = 36
        
    ' 小さい円の個数（Small Circle Count）。
    Dim scc As Long
        scc = 3
    
    ' 表の最大列数。
    Dim cMax As Long
        cMax = 2 + 3 * scc

    ' グラフリセット。
        Cells(1, 1).Resize(Rows.Count - 1, Columns.Count).Clear

    
    ' 大きい円と小さい円を分割する角度（rad）。
    Dim dθ(1 To 2) As Double
        dθ(1) = 2 * π / dc
        dθ(2) = -r(1) / r(2) * dθ(1)
    
    ' 全描画に必要なグラフの行数。
    ' ※大きな円の描画に必要な点　dc+1 ←始点と終点を重ねないと円が閉じない。
    ' ※小さな円の描画に必要な点と動点Ｐの軌跡描画に必要な点の数は等しい。
    Dim rMax As Long
        rMax = (dc + 1) * (scc + 1) + (dc * rn + 1) * scc + scc+1
               
    Dim myChart As ChartObject
    Set myChart = ActiveSheet.ChartObjects(1)
        myChart.Chart.SetSourceData Source:=Cells(1, 1).Resize(rMax + 1, cMax)
               
    ' 各座標を格納するための配列。
    ' 一次元を０始まりにするのは、ラベル名を格納するため。
    Dim c As Long
    Dim arr() As Variant
    ReDim arr(rMax, 1 To cMax)
        arr(0, 1) = "X"
        For c = 2 To cMax
            arr(0, c) = "Y" & c - 1
        Next
    
    ' 大きい円の座標。
    Dim x1() As Double: ReDim x1(1 To dc + 1)
    Dim y1() As Double: ReDim y1(1 To dc + 1)
    ' 小さい円の座標。
    Dim x2() As Double: ReDim x2(1 To dc * rn + 1)
    Dim y2() As Double: ReDim y2(1 To dc * rn + 1)
    
    ' 小さい円の中心。
    Dim ox2() As Double: ReDim ox2(1 To dc * rn + 1)
    Dim oy2() As Double: ReDim oy2(1 To dc * rn + 1)

    ' 小さい円の中心からr(3)オフセットしたポイント。
    Dim x3() As Double: ReDim x3(1 To dc * rn + 1)
    Dim y3() As Double: ReDim y3(1 To dc * rn + 1)
        
    Dim i As Long
    Dim j As Long
    Dim k As Long: k = scc
    
        ' 大きな円の描画。
        For i = 1 To dc + 1
            x1(i) = r(1) * Cos(dθ(1) * (i - 1))
            y1(i) = r(1) * Sin(dθ(1) * (i - 1))
            arr(i, 1) = x1(i)
            arr(i, 2) = y1(i)
        Next
    
        ' 続けて描画するため、iの最終値を保存。
    Dim LastIndex As Long
        LastIndex = i
        
        For i = 1 To dc * rn + 1
        
            Application.Wait [Now() + "00:00:00.03"]
            DoEvents
            
            For c = 1 To scc
        
                ' 小さな円の中心。
                ox2(i) = r(1) * Cos(dθ(1) * (i - 1) + 2 * π / scc * (c - 1)) * (r(1) - r(2)) / r(1)
                oy2(i) = r(1) * Sin(dθ(1) * (i - 1) + 2 * π / scc * (c - 1)) * (r(1) - r(2)) / r(1)
    
                
                ' 小さい円を描画。
                For j = 1 To dc + 1
                    x2(i) = ox2(i) + r(2) * Cos(dθ(1) * (j - 1))
                    y2(i) = oy2(i) + r(2) * Sin(dθ(1) * (j - 1))
                    arr(LastIndex + j - 1 + (c - 1) * (dc + 1), 1) = ox2(i) + r(2) * Cos(dθ(1) * (j - 1))
                    arr(LastIndex + j - 1 + (c - 1) * (dc + 1), c + 2) = oy2(i) + r(2) * Sin(dθ(1) * (j - 1))
                Next
                
'                ' 中心からオフセットしたポイント。
                x3(i) = ox2(i) + r(3) * Cos(dθ(2) * (i - 1))
                y3(i) = oy2(i) + r(3) * Sin(dθ(2) * (i - 1))

                arr(LastIndex + scc * (dc + 1) + (c - 1), 1) = ox2(i) + r(3) * Cos(dθ(2) * (i - 1))
                arr(LastIndex + scc * (dc + 1) + (c - 1), 2 + scc + c) = oy2(i) + r(3) * Sin(dθ(2) * (i - 1))

                arr(LastIndex + scc * (dc + 1) + (c - 1) * (dc * rn + 1) + k, 1) = x3(i)
                arr(LastIndex + scc * (dc + 1) + (c - 1) * (dc * rn + 1) + k, 2 + 2 * scc + c) = y3(i)
               
            Next

            k = k + 1
            
            Cells(1, 1).Resize(rMax, cMax) = arr
        Next

End Sub