スキルアップ・問題解決なら、モーグにおまかせ！

「Fractal」
https://www.moug.net/faq/viewtopic.php?t=82394
について、検討してみました。
 
【用意するもの】
・Sheet1 描画用のシート（特段の準備は不要）
・Sheet2 カラー用の情報を持たせるもの。
           最下段にあるデータをコピーペイストしてください。
 
【手順】
1. 下記のコードを標準モジュールにコピーペイストして下さい。
2. main プロシージャを実行してください。
    7,8秒で描画が完成するはずです。
 
【参考コード】

Dim ws As Worksheet
Dim wsColor As Worksheet
Sub main()
    Dim n&                  ' & は As Longと同じ
    Dim baseX&, baseY&, m&
    Dim mx#, my#, w#        ' # は As Doubleと同じ
    Dim u#, v#
    Dim rng   As Range
    Dim i&, j&, l&

    Set ws = Worksheets("Sheet1")      '描画用シート
    Set wsColor = Worksheets("Sheet2")  'カラー情報  

    Application.ScreenUpdating = False

    n = 200             '収束判定の繰返し上限
    baseX = 200         '書き込みセルの基準位置(描画範囲の中点）
    baseY = 200
    m = 199             'mesh（上下、左右とも約400に分割）

    '複素平面上の点の範囲設定
    mx = -0.6           'X軸方向の中点
    my = 0#             'Y軸方向の中点
    w = 1.4             '片側の幅
    '(x軸方向[-2.0,0.8]、y軸方向[-1.4,1.4]の範囲)
        
    '青系統のカラーマップを利用
    Dim colormap As Variant
    colormap = getColorMap()

    With ws
        Set rng = .Cells(1, 1).Resize(2 * m + 1, 2 * m + 1) '描画範囲
        .Activate
        ActiveWindow.Zoom = 100
        rng.EntireRow.RowHeight = 3.75
        rng.EntireColumn.ColumnWidth = 0.38
        rng.ClearFormats

        For i = -m To m
            u = mx + w * i / m
            For j = -m To m
                v = my + w * j / m
                l = mandelbrot(u, v, n) '初めて半径２の円の外に出るまでの繰返し回数

                'セルに着色
                If l >= n Then  '最後まで外に出ない（収束）ケース
                   .Cells(baseY + j, baseX + i).Interior.Color = RGB(0, 0, 0)    '黒
                Else
                   .Cells(baseY + j, baseX + i).Interior.Color = colormap(n - l) '青系 
                End If
            Next
        Next
        .Activate
        ActiveWindow.Zoom = 50
    End With
    Application.ScreenUpdating = True
    MsgBox "終了"
End Sub

Function mandelbrot(u#, v#, n&) As Long
  'f = z^2 + c（複素平面上）で、z=0からスタートし z[n+1] = f(z[n]) で順次z[n]を計算
  '収束判定を実行（既定の円領域をはずれたときに発散と判断）
  'そのときまでの繰り返し回数を返す
    Dim l&, x#, y#, zx#, zy#
    x = 0: y = 0
    For l = 1 To n
        zx = x ^ 2 - y ^ 2 + u
        zy = 2 * x * y + v
        x = zx: y = zy
        If x ^ 2 + y ^ 2 > 4 Then Exit For    'みなし発散判定
    Next
    mandelbrot = l
End Function

Function getColorMap() As Variant
    Dim j&, k&
    Dim mat(1 To 200)
    For j = 1 To 8
        For k = 1 To 25
            mat(k + (j - 1) * 25) = wsColor.Cells(k, j)
        Next
    Next
    getColorMap = mat
End Function

16710898  16710897  16644845  16578791  16446684  16248008  15850143  14789457
16710898  16710897  16644845  16578791  16446684  16248006  15849885  14657614
16710898  16710896  16644845  16578791  16446683  16182213  15784090  14591306
16710898  16710896  16644845  16578790  16446683  16182212  15783832  14459206
16710898  16710640  16644845  16578790  16446426  16181955  15783318  14327362
16710898  16710640  16644844  16578790  16446425  16181954  15717523  14195262
16710898  16710640  16644844  16578789  16380889  16181696  15717264  14063163
16710898  16710640  16644844  16578533  16380888  16181695  15716750  13865527
16710898  16710640  16644844  16512997  16380631  16115902  15650955  13667892
16710898  16710640  16644844  16512996  16380630  16115644  15650440  13470001
16710898  16645104  16644843  16512996  16380630  16115643  15584645  13272366
16710898  16645103  16644843  16512995  16380373  16115385  15584130  13008939
16710898  16645103  16644843  16512995  16380372  16115128  15518335  12679977
16710898  16645103  16644843  16512995  16380371  16049590  15517820  12351015
16710898  16645103  16644586  16512738  16314834  16049332  15451769  12021797
16710897  16645103  16579050  16512738  16314578  16049075  15385718  11627299
16710897  16645103  16579050  16512737  16314577  16048817  15385202  11232545
16710897  16645103  16579050  16512737  16314320  15983279  15319151  10772255
16710897  16645102  16579049  16512736  16314319  15983021  15253099  10311965
16710897  16645102  16579049  16512736  16314318  15982763  15186792  9785883
16710897  16645102  16579049  16512479  16314061  15982505  15120740  9194521
16710897  16645102  16579049  16446943  16248524  15916712  15054433  8602903
16710897  16645102  16579048  16446942  16248523  15916453  14988381  7945748
16710897  16645102  16579048  16446942  16248266  15916195  14922073  7288593
16710897  16645102  16578792  16446941  16248265  15850401  14855765  6500110

Simpleさん
大変遅くなりましたがご指摘内容について検討しました。
Sheet1には模様のない黒色のブロックが出現している状態でstopしています。
 
＞■Sheet2の A1:H25に下記の数値をコピーペイストして下さい
ということで８ｘ２５のマトリックスをコピーすることになりますが
各セル毎に１つの数値が入ることが前提ですね。
先頭のセルにのみ８個の数値が入力されている状態になっています。
これが正常動作していない原因だと思われます。
次元の低い話で恐縮ですが、各セル毎に１つの数値を入力する方法を教えていただけないでしょうか。
 

・ブラウザーからコピーペーストすると、A列に文字列として書き込まれます。
（ここまではOKですね）
・次に、「データ」 ‐ 「区切り位置」 を使い、
・「スペース」 を 区切り文字として指定して実行すると、各セルに展開されます。
不明なら、ネットで「Excel　区切り位置」を検索して調べて下さい。
 
A列が文字列になってしまうかもしれないので、数値に変更してください。
（2種類しかないので手作業でも）

Simoleさん
ありがとうございます。
＞「データ」 ‐ 「区切り位置」 を使い、
＞「スペース」 を 区切り文字として指定して実行すると、各セルに展開されます。
でSHEET2にデータが準備でき、SHEET1に描画できました。N-BASICの描画よりはるかに精密なものです。
 
【参考コード】は、こちらが投稿した
https://www.moug.net/faq/viewtopic.php?t=82394
をベースにして展開されたのでしょうか。
FRACTALはこのほかにも、N-BASICでのプログラムはシンプルでも複雑で多彩な描画できるものが多数あります。
それをVBAにportingしたいと思っています。

いえいえ、それはまだまだドット数が粗いので、自己相似性のようなものはわかりにくいですよ。
ネット上にあるものを調べられると、より詳細な画像をみることができると思います。
 
ジュリア集合やマンデルブロー集合などのフラクタルや、ロジスティック写像のようなカオスも面白いです。
後者のなかにもマンデルブロー集合に類似の極めて複雑な紋様が現れて、驚かされます。
 
なお、マンデルブロー集合そのものの計算はさほど難しいことはありませんね。
カラーマップの作製(VBAでの再現）が大変でした。
RGBだけではなく、色々な色空間の知識が必要で、とても大変でしたが面白くはありました。
 
ExcelVBAの話題から逸れて行きますので、この辺で閉じることとします。