Excelで渦巻状にセルを移動するマクロを作りたいのです

質問

マクロで渦身状＆時計回りにアクティブセルを移動させるにはどのように
記述したらよいでしょうか。

例えば、E16を選択しているときにマクロを実行したら
E16→D16→D15→D14→E14→F14→F15→F16→F17→E17→D17→C17→…
と移動していく感じです。

キーボード記録マクロで[↑][↓][←][→]キーで移動してみても何も記録
されなかったので、移動→黄色に塗りつぶし、という繰り返しを記録
してみると、文末のようにはなりました。が、渦巻き状に移動という
アルゴリズムがさっぱり思いつきません。
無限でなく、例えば１０周くらいまわれば十分です。

最終的には、移動するごとに、踏んだセルの値を評価（1だったら赤に塗る、
のように）していきますが、まずは選択セルを基点に渦巻状にセルを移動
する方法が知りたいです。

よろしくお願いします。

Sub Macro1()
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Range("E16").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Range("D16").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
' ■中略■
Range("C17").Select
With Selection.Interior
End Sub

.ColorIndex = 6
.Pattern = xlSolid
End With

（ちなみに）
エクセル上に、日本地図が碁盤目状に描かれています。
セルには、平野＝１、山＝２、海＝３のように記述されています。
これを特定法則で塗り分けるのに利用します。

回答No.9

Wendy02 · ベストアンサー

こんばんは。

分りました。

If IsEmpty(myRemain) Or
　　Param1=0 Or
　　Param2 =0 Then
　　 MsgBox "初期設定がされていません。", vbCritical: Exit Sub
　 End If

でした。理由は、Param1, Param2 は、Long型なので、何も入れない状態は　0 で、Emptyではありませんでした。失礼しました。

次に、結合セルの場合は、

× Param1 = Range("A2:D2").Value
× Param2 = Range("A3:D3").Value

必ず、左端の番地を設定し
Param1 = Range("A2").Value
Param2 = Range("A3").Value

として扱ってください。

＞型が違うとエラーになりますし、
型は、この場合は、Variant型ですが、値は、配列変数になってしまいますので、関数でも取り付けないと、取り出せなくなってしまいます。

なお、ここの掲示板は、回答のお礼側にコメントをつけると、直接回答者にメールされるシステムになっております。日にちが経過した場合は、できましたら、回答のお礼側にちょっと書いてくれると、直接ここに飛べますので、何かと助かります。

もちろん、私の方も、MyPageをやめて、ここのカテゴリのタイトル・ログをVBAでチェックできるように、プログラムを作ってありますが、標準で、5ページまでになっています。もう、そろそろ、このご質問が5ページ・ラインを越えようとしていますので、よろしくお願いします。

お礼

Wendy02さん、このたびの質問では、貴重なマクロを
ご提供いただき、本当にありがとうございました。

初期設定がゼロの場合も、無事クリアできました。
エスケープキーでご実現いただいた中断というのも、
欲しかったんです(^^;;
無理にEscだと、エラーで中止したみたいで、何かイヤですものね(^^;

いくつかの要望も200%満足できるものに仕上げていただけました。
既にかなりいろいろ試させていただいたのですが、
コメントが豊富で、大変柔軟に設計いただいたおかげで、
何とか改造もできそうな感じです。
おかげさまで、今後とも大活躍できることは間違いなさそうです。

それと最後に。わたしは、
数ヶ月前に、散布図をピラミッド状に作図するマクロも質問した者です。
Wendy02さんが覚えていらっしゃるかわかりませんが、
あの時もWendy02さんには、大変親身に相談に乗っていただきました。
結果的に、サンプルマクロをわたしのFTPサーバーにアップしていたため、
個人を特定できる可能性がある利用規約に違反とかいう理由で
主催のgooさんに削除されてしまい、お礼が言えずじまいになって
いました。それが、本当に心残りでした。
おかげさまで、あの時に作っていただいた散布図マクロも、
現役で使い倒させていただいてます。
この件についても、どうしても御礼を申し上げたかったので。

あ、それと、回答のお礼への記入は了解しました、以後注意いたします。
大変失礼しました。

あとは、自力でこのような有用なマクロを作れるよう努力しなければ
なりませんが、今後とも、どうぞよろしくお願い致します。

回答No.8

Wendy02

KenKen_SPさまへ

どうもフォローありがとうございます。
実は、これは、何もないところは、極端に動きが速くなります。（そのように設計してあります）。本来は、何もないところは、Application.ScreenUpdating のTrue/False を使いたいとは思っているのですが……。そうでもしないと、頭の締め付けられるような鈍痛から痛みに発展します。それでも、継続的に使うのは、私には無理です。私には、こういうのは向いていないようです。

＞DoEvents を入れると良いと思います。

Do の二番目の下あたりに、DoEvents を入れたほうがよいかもしれませんね。

回答No.7

Wendy02

こんばんは。

私個人としては、数回しか、このマクロを試すことが出来ません。どうしても、このような単純な動きのものは、目に残像が焼き付いてしまいます。ですから、すぐに取り掛かれないので、返事が遅くて申し訳ありません。

ご要望どおりかわかりませんが、オプションをつけました。
抜けていたら、ご指摘ください。

　・Case 2 ～3 について、色を塗り、減算します。
　その場合は、任意ですが、Param1, Param2 変数におけるようにしました。
　また、Range("A1")をValueTotal として、変数名をつけ、あちこちで使えるようにしました。
　　－つまり、A1だけでなく、画面の左下のステータスバーに、セル内の1を踏むと、残がその都度表示させるようにしました。

・エスケープキーで、途中で止められるようにしました。そのまま継続するかどうか聞い　てきます。継続するなら、そのまま続けます。（もし、この部分をいじるときは、気をつけてくださいね。必ず、Application.EnableCancelKey = xlInterruptで終了させることを心がけてください。）

・終了時は、B2に行くようにしました。

Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim ValueTotal As Range
Dim Param1 As Long
Dim Param2 As Long
Sub SpritalPaint()
　 Dim myRemain As Long, bln As Boolean
　 Dim r As Integer, c As Integer, m As Integer, n As Integer
　 Dim i As Integer, j As Integer, myPos As Range
　 '------　初期設定---------
　 Set myPos = Range("BE73")　'開始番地

　 Set ValueTotal = Range("A1") '初期値を入れる場所
　 myRemain = ValueTotal.Value　'パラメータ
　 Param1 = Range("A2").Value
　 Param2 = Range("A3").Value
　 If IsEmpty(myRemain) Or IsEmpty(Param1) Or IsEmpty(Param2) Then
　　 MsgBox "初期設定がされていません。", vbCritical: Exit Sub
　 End If
　 '---------設定終わり-----------
　 bln = DecreaseCheck(myRemain, myPos.Value)
　 myPos.Interior.ColorIndex = 1
　 Application.EnableCancelKey = xlErrorHandler
　 On Error GoTo Errhandler
　 myPos.Select
　 Sleep 100
　 m = 1
　 While ActiveCell.Column <> 1
　 i = i + 1
　　　Do
　　　　 If j = 0 Then
　　　　　　r = m: c = 0
　　　　　　Else
　　　　　　r = 0: c = m
　　　　 End If
　　　　 Do
　　　　　　 With ActiveCell.Offset(r, c)
　　　　　　　 .Select
　　　　　　　 If .Value > 0 Then
　　　　　　　 bln = DecreaseCheck(myRemain, .Value)
　　　　　　　 If bln = True Then
　　　　　　　　 GoTo Errhandler
　　　　　　　 End If
　　　　　　　 If .Value = 2 Or .Value = 3 Then
　　　　　　　　　　.Interior.ColorIndex = 1
　　　　　　　 End If
　　　　　　　 Sleep 100
　　　　　　　End If
　　　　　　End With
　　　　　　n = n + 1
　　　　 Loop Until i = n
　　　　 n = 0
　　　　 If j = 0 Then
　　　　 If m = 1 Then m = -1 Else m = 1
　　　　 End If
　　　　 j = j + 1
　　　Loop Until j = 2
　　　j = 0
　 Wend
Errhandler:
　If Err.Number = 18 Then
　 If MsgBox("エスケープキーが押されましたので中断します。継続しますか？", 64 + vbYesNo) = vbYes Then
　　　Resume
　 Else
　　　MsgBox "移動を中止します。肥料はあと「" & Format$(myRemain, "#,##0") & "」トン残っています。"
　 End If
　ElseIf Err.Number > 0 Then
　 MsgBox "Err : " & Err.Description, 16
　 Range("B2").Select
　End If
　If ActiveCell.Column = 1 Then
　　Range("B2").Select
　　MsgBox "限界に達したので移動を中止します。肥料はあと「" & Format$(myRemain, "#,##0") & "」トン残っています。"
　 End If
　If bln Then
　　Range("B2").Select
　　MsgBox "肥料がなくなりました。肥料を撒いたところは黒く塗られました。"
　End If
　Application.EnableCancelKey = xlInterrupt
　On Error GoTo 0
　Application.StatusBar = False
　Set myPos = Nothing
　Set ValueTotal = Nothing
End Sub
'ザフルーチン

Private Function DecreaseCheck(ByRef lngTotal As Long, varUnit As Variant) As Boolean
　Dim DecreValue As Long
　Dim lngUnit As Long
　lngUnit = CLng(varUnit)
　'単位に対する実際の値を入力してください。
　Select Case lngUnit
　Case 1
　　 Application.StatusBar = "現在値 : " & Format$(lngTotal, "#,##0")
　Case 2
　　DecreValue = Param1
　Case 3
　　DecreValue = Param2
　Case Else
　　　DecreValue = 0
　End Select
　lngTotal = lngTotal - DecreValue
　ValueTotal.Value = lngTotal
　If lngTotal <= 0 Then
　　DecreaseCheck = True
　End If
End Function

補足

Wendy02さん、たびたびのバージョンアップ本当にありがとうございます。
感謝の気持ちもあるので、後でゆっくりお礼＆動作報告レスを
書かせていただきますが、一点だけ：

　 Param1 = Range("A2").Value
　 Param2 = Range("A3").Value
　　　　　　　（略）
If IsEmpty(myRemain) Or IsEmpty(Param1) Or IsEmpty(Param2) Then
　　 MsgBox "初期設定がされていません。", vbCritical: Exit Sub
　 End If

とありますが、A2とA3が空白（Delete押下でクリア）しても、MsgBoxが
出てきませんが、なぜでしょうね。

A2とA3が結合セルで、正確にはそれぞれ、A2:D2、A3:D3なのですが、
　 Param1 = Range("A2:D2").Value
　 Param2 = Range("A3:D3").Value
としてみると、型が違うとエラーになりますし、実に不思議です。

回答No.6

KenKen_SP

こんにちは。KenKen_SP です。

Wendy02 さん、さすがでございます。m(__)m

蛇足かもしれませんが、、

画面の変化が激しいと PC によっては、Application.ScreenUpdating=False
がなくとも画面描写が一時停止することがありますので、DoEvents を入れる
と良いと思います。

Excel VBA でアニメーションを作成したときの経験からです。

回答No.5

Wendy02

こんばんは。

遅くなりました。昨日、目に渦巻きの残像が残って、途中で気分が悪くなってPCからリタイアしたのでした。(@_@)　昨日使った、Wait 1秒を、API関数を使い10分の１秒にしました。1000で、1秒です。Sleepの100は、視覚的な時間の最小単位だと思ってください。数値の何もないところは、Waitが掛からないので、画面が大揺れに動きます。Application.ScreenUpdating をこまめに使えば、画面は落ち着くかもしれませんが、今は入れていません。生のままを見てください。

実際の値は、ユーザー定義関数　DecreaseCheckのCase のUnit の値のところとあわせて入力してください。

'<標準モジュール推奨>

Option Explicit
'Win32 API関数
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub SpritalPaint()
　 Dim myRemain As Long, bln As Boolean
　 Dim r As Integer, c As Integer, m As Integer, n As Integer
　 Dim i As Integer, j As Integer, myPos As Range
　 '設定
　 Set myPos = Range("BE73")
　 '初期値
　 myRemain = Range("A2").Value
　 '
　 bln = DecreaseCheck(myRemain, myPos.Value)
　 myPos.Interior.ColorIndex = 1
　 On Error GoTo Errhandler
　 myPos.Select
　 Sleep 100　'0.1 秒
　 m = 1
　 While ActiveCell.Column <> 1
　 i = i + 1
　　　Do
　　　　 If j = 0 Then
　　　　　　r = m: c = 0
　　　　　　Else
　　　　　　r = 0: c = m
　　　　 End If
　　　　 Do
　　　　　　 With ActiveCell.Offset(r, c)
　　　　　　　 .Select
　　　　　　　 If .Value > 0 Then
　　　　　　　 bln = DecreaseCheck(myRemain, .Value)
　　　　　　　 If bln = True Then
　　　　　　　　 GoTo Errhandler
　　　　　　　 End If
　　　　　　　.Interior.ColorIndex = 1
　　　　　　　 Sleep 100　'0.1秒
　　　　　　　End If
　　　　　　End With
　　　　　　n = n + 1
　　　　 Loop Until i = n
　　　　 n = 0
　　　　 If j = 0 Then
　　　　 If m = 1 Then m = -1 Else m = 1
　　　　 End If
　　　　 j = j + 1
　　　Loop Until j = 2
　　　j = 0
　 Wend
　 If ActiveCell.Column = 1 Then
　　MsgBox "限界に達したので移動を中止します。肥料はあと「" & myRemain & "」トン残っています。"
　 End If
　 Exit Sub
Errhandler:
　If Err.Number > 0 Then
　 MsgBox "トラブルが発生しました。", vbCritical
　 End If
　If bln Then
　　MsgBox "肥料がなくなりました。肥料を撒いたところは黒く塗られました。"
　End If
End Sub

Private Function DecreaseCheck(ByRef lngTotal As Long, varUnit As Variant) As Boolean
　Dim DecreValue As Long
　Dim lngUnit As Long
　lngUnit = CLng(varUnit)
　'単位に対する実際の値を入力してください。
　Select Case lngUnit
　Case 1
　　DecreValue = 500
　Case 2
　　DecreValue = 1000
　Case 3
　　DecreValue = 2000
　Case 4
　　DecreValue = 3000
　Case 5
　　DecreValue = 4000
　Case 6
　　DecreValue = 5000
　Case 7
　　DecreValue = 6000
　Case 8
　　DecreValue = 7000
　Case 9
　　DecreValue = 8000
　Case 10
　　DecreValue = 9000
　Case 11
　　DecreValue = 10000
　Case Else
　　　DecreValue = 0
　End Select
　lngTotal = lngTotal - DecreValue
　If lngTotal <= 0 Then
　　DecreaseCheck = True
　End If
End Function

お礼

すみません、自分で試行錯誤してみたところ、
昨晩記入させていただいた項目のうち、

(1) 田と畑にまく初期値をセル指定、
(2) 残り肥料量を指定セルに表示、

は何とか実現できました。

(1) については、DecreaseCheck関数内で、
　　Dim myTanbo As Long
　　Dim myHatake As Long
を宣言し、
　　Case 2
　　　DecreValue = myTanbo
　　Case 3
　　　DecreValue = myHatake
のようにすれば良いのですね。

(2) についても、
　　MsgBox "限界に達したので（略）...
　　MsgBox "屎尿がなくなりました（略）...
などの前に
　　Range("B2").Select
　　ActiveCell.FormulaR1C1 = myRemain
などとすれば良いようです。

引き続き、

＞踏んだセルの値が「Case 2」と「Case 3」以外（即ち1,4,5,6,7,8,9,10,11）でも、
＞黒に塗られてしまいます。

の件は自己解決を目指してみますが、もし変更方法など
ありましたら、引き続きご教示いただけますと幸いです。

補足

Wendy02さん、再々のご教示、本当にありがとうございます！

わたしの要望のために、体調をくずさせてしまい、大変恐縮です。

実は以前から是非実現したい試算だったので、要望させていただいた
マクロをご提示いただくのが、もう楽しみで楽しみで。
今日一日だけで10回くらいレスの有無を確認に訪れてしまいました(^^;。

まず、1秒（TimeValue("00:00:01")）より、もう少し速くなると
ありがたいなぁ～なんて贅沢なことを薄々要望しかけていたのですが、
そこまで汲んでいただけたなんて、本当に至れり尽くせりです。

それと、「画面が大揺れに動」く件は、むしろこの方が、動作を監視できる意味で
都合がよいです。まずは御礼申し上げます。
早速、ワクワクしながらためさせていただきました。

先に記しましたとおり、各セルに、1～11までの数値が埋まっているのですが、
自分なりにご提示いただいたスクリプトを解読しつつ、

(1) 「A2」番地に、1000000などと初期値（所持している肥料量）を記入し、

(2)田（踏んだセルの値が2）の時と、畑（踏んだセルの値が2）の時だけ、
それぞれ1000、2000を差し引くよう、 DecreaseCheck関数の中の

---ここから
　Case 2
　　DecreValue = 1000
　Case 3
　　DecreValue = 2000
---ここまで

だけを残し、あとの「Case～～」部はコメントアウトしてみたのですが、
踏んだセルの値が「Case 2」と「Case 3」以外（即ち1,4,5,6,7,8,9,10,11）でも、
黒に塗られてしまいます。ここは、「Case 2」と「Case 3」のときだけ、黒にしたいのです。
（1,4,5,6,7,8,9,10,11のときは、何も塗らない、というか、元の色を維持します）
それと、説明不足でしたが、田と畑以外に肥料を撒くことはないです。すみません。

それと、元質問（No.2の"回答に対する補足"）の初期パラメータに関する
記述に誤りがありました。本当にすみません。正しくは、Excelシートでたとえると：

　|　　　　　A　　　　　　　　　　　　|　　　　　B
-----------------------------------------
1|　手持ちの肥料量　　　　　　｜残り手持ち肥料量（移動/減算がなされる度に）現在値が
-----------------------------------------表示されれば最高ではありますが、
2|　田(2)のときを差し引く量　　|　　　　　　　　　　A列の到達時にmyRemain値が表示されれば十分です）
-----------------------------------------
3|　畑(3)のときを差し引く量　　|
-----------------------------------------

・・・のような感じです。より具体的な数値で示しますと、次のようなイメージです。

　|　　　　A　　　|　　　B
-------------------
1|　1000000　|1000000 ←渦巻き移動開始前は何も差し引かれていないのでA1と同じ値
-------------------
2|　1000　　　｜
-------------------
3|　2000　　　｜
-------------------

現状：
田を踏んだ時に差し引く1000と
畑を踏んだ時に差し引く2000は、
マクロの中の「Case 2」と「Case 3」を手動で書き換えなければならないですよね？
これらの値は、マクロ内でなく、Excelシート（田はA2セル、畑はA3セル）から
変数として受け取れるように仕様変更いただくことは容易でしょうか
（難度の見当がつかず、あつかましい要望ですみません）。

と申しますのは、
(1) 手持ち肥料量の初期値（1000000）と、
(2) 田を踏んだ時の減点値（1000）、および
(3) 畑を踏んだ時の減点値（2000）
以上、三種類のパラメータは、頻繁にとっかえひっかえして試算したいため、
VBEを開かずとも、シートに直接記述し、マクロ実行時にマクロが変数として
シートを読みにいくようにできると大変助かるのです。

以上、もしよろしければお付き合いいただけますと
大変幸いでありますが、既に素晴らしいご回答を
お寄せいただきましたので、まずは御礼申し上げます。

回答No.4

Wendy02

litton101さま

一両日、お待ちください。

必ず、もう一度、アップしますので、閉めないでくださいね。

補足

Wendy02さん、大変身勝手な要望にお返事いただきまして
ありがとうございます。

事前準備として、

111111111222
333333311111
221111111111

のようなセル群に、#1さんのマクロをアレンジして
11種類に塗り分けてあります。

Wendy02さんのマクロはこの着色された地図の上に
適用する予定でおります。

どうぞ、よろしくお願い致します。

回答No.3

KenKen_SP

こんにちは。KenKen_SP です。

> セルには、平野＝１、山＝２、海＝３のように記述されています。
> これを特定法則で塗り分けるのに利用します。

これが目的であれば、要素数3つまでの場合には条件付き書式で
着色するのが楽でいいかなと思います。
要素数はもっとありますか？

マクロで渦巻状にセルに着色していくのは、ビジュアル的な効果が
目的なのでしょうか？

お礼

KenKen_SPさん、レスありがとうございました。

説明不足ですみませんでしたが、渦巻き状、というのがポイントでした。

単に塗るだけなら、条件付書式というのはいい方法ですね。
参考にさせていただきます。

回答No.2

Wendy02

こんばんは。

あまり、きちんと考えて作ったものではありません。ただ、もし良かったら試してください。それから、10週というと、最初の位置を考えないといけませんね。E15 ですと、8週ぐらいにしかならないと思いますが、とりあえず、元の位置からということで作ってみました。

それから、目に見える形にするために、Wait を1秒入れました。

Sub SpritalTest()
　 Dim r As Integer, c As Integer, m As Integer, n As Integer
　 Dim i As Integer, j As Integer, myPos As Range
　 '設定
　 Set myPos = Range("E15")
　 myPos.Interior.ColorIndex = 6
　 On Error GoTo Errhandler
　 myPos.Select
　 Application.Wait Now + TimeValue("00:00:01")
　 m = 1
　 For i = 1 To 8
　　　Do
　　　　 If j = 0 Then
　　　　　　r = m: c = 0
　　　　　　Else
　　　　　　r = 0: c = m
　　　　 End If
　　　　 Do
　　　　　　ActiveCell.Offset(r, c).Select
　　　　　　Selection.Interior.ColorIndex = 6
　　　　　　Application.Wait Now + TimeValue("00:00:01")
　　　　　　n = n + 1
　　　　 Loop Until i = n
　　　　 n = 0
　　　　 If j = 0 Then
　　　　 If m = 1 Then m = -1 Else m = 1
　　　　 End If
　　　　 j = j + 1
　　　Loop Until j = 2
　　　j = 0
　 Next i
　 Exit Sub
Errhandler:
　MsgBox "セルの領域を越えました", vbCritical
End Sub

補足

Wendy02さん、いつもお世話になってます。

さっそく動作確認させていただきました。
まさにこういうやつです！！感謝にたえません、

しかも、
＞Wait を1秒
実はこれも欲しかったんです、本当に至れり尽くせりで嬉しいです。

かなり説明が足りずすみませんでしたが、最終的に以下のような
簡単なシミュレーションをしたい次第です。

まず、日本地図があり、Sheet1のA4:DM123（117×120マス）のセルに
平野＝1、田＝2、畑＝3、山＝4、海＝5、のように地形を数値で
入れてあります（全部で1～11まで、11種類の数値が使われています）。

(1) 初期値として手持ちの肥料が1,000,000トンあるとします。
　→セルのA1番地に1,000,000と記入してあります。
(2) 例えば、踏んだセルが2(田)なら1000トン、3(畑)なら2000トンの
　　肥料を撒くものとします。
　→セルのA2番地に1000、A3番地に2000と記入してあります。
(3) スタートは、必ず「BE73」番地です。

そこで、以下のひょうな規則性をWendy02さんのマクロに埋め、
渦巻状の移動を繰り返したいです。

■ロジック１
if (踏んだセル＝2(田））{
　　そのセル.ColorIndex　＝　1（黒）に塗る
　　AAA　＝　A1セルの値（手持ち肥料）　－　A2セルの値（1000トン）
　　A2セルに現在の残り手持ち肥料である「AAA」を表示
}elseif (踏んだセル＝3(畑））{
　　そのセル.ColorIndex　＝　1（黒）
　　AAA　＝　A1セルの手持ち肥料　－　A3セルの値（2000トン）
　　A2セルに現在の残り手持ち肥料である「AAA」を表示
}else{
　　なにもしないで次のセルに渦巻き法則で移動
}

■ロジック２
if(　AAA（手持ちの肥料）　＝　0（無くなった）){
　　ループを抜ける
　　MsgBox ("肥料がなくなりました。肥料を撒いたところは黒に塗られました")
}

■ロジック３
スタートセル「BE73」は、日本地図の中央ではありません。
渦巻き移動を繰り返すとやがて、地図の上下左右の末端までたどり着きます。
最初にたどり着くのは、地図の下辺ですが、無視して渦巻き移動は続けます。
次にたどり着くのは、地図の左辺です。これでループを抜け、
　　MsgBox ("限界に達したので移動を中止します。肥料はあと「AAA（A2の値）」トン残っています")

こんな感じなのですが、もし簡単にご実装いただけるようでしたら
ご教示いただけますと幸いです（あつかましい質問スミマセン）。

まずは心より御礼申し上げます。

回答No.1

missile_man

こんばんわ。
とりあえず色を塗るマクロです。

SelectionやRangeは処理が重いので
Sheet1.Cells(1 , 1)でセルを指定した方が
早いです。

Sub test()

Do Until Y = 100

Do Until X = 100

iro = Sheet1.Cells(1 + X, 1 + Y)

Select Case iro

Case 1 '平野(みどり)
Sheet1.Cells(1 + X, 1 + Y).Interior.ColorIndex = 4

Case 2 '山（茶）
Sheet1.Cells(1 + X, 1 + Y).Interior.ColorIndex = 12

Case 3 '海（青）
Sheet1.Cells(1 + X, 1 + Y).Interior.ColorIndex = 5

End Select

X = X + 1

Loop

X = 0
Y = Y + 1

Loop

End Sub

これだと、セルA1を起点に100×100のマスを
塗ります。
iro = Sheet1.Cells(2 + X, 2 + Y)
だと、セルB2が起点

渦巻きにしたいのであれば、
”X = 0”や”Y = Y + 1”や”X = X + 1”の
所に式を作れば可能です。

お礼

missile_manさん、早速のマクロありがとうございました。

後々、ご提示の色塗りも必要だったんです。

というか、応用範囲が広そうなので、今後とも大いに
活用させていただきます。