５×６マス検索→５×５マス検索への改造の仕方。

質問

いつもお世話になっております。
先日こちらで、「検索値と同じ値か、隣接数字との差が０か１なら塗潰す」を
質問させて頂き、回答をいただきました。
この時は５×６マスが４つあるケースでしたが、
これを、以下の様に５×５マスが４つあるケースでは
どうすればよいでしょうか？
マスが変更になった以外は前回と変更ありません。
できれば、5×7マスが４つのケースも教えて頂けると助かります。

　1つ目の5×5マス：A1~E5
　2つ目の5×5マス：G1~K5
　3つ目の5×5マス：A7~E11
　4つ目の5×5マス：G7~K11

　 Ａ　B　C　Ｄ　Ｅ　　Ｆ　G　Ｈ　Ｉ　Ｊ　Ｋ　　
1　01　08　11　18　25 　　03　06　17　20　24
2　02　19　23　26　27 　　01　08　16　18　25
3　10　15　28　29　30 　　02　11　19　23　26
4　04　07　12　14　21 　　10　15　27　28　30
5　05　09　13　22　31 　　04　07　12　21　29
6
7　08　11　12　20　28　　04　15　17　25　31
8　06　07　22　23　26　　01　09　13　19　29
9　01　09　19　24　29　　10　11　14　24　28
10　03　10　14　18　27　　03　05　18　21　27
11　02　05　16　21　30　　02　16　17　30　31
＊＊＊＊＊＊　以下は前回の質問　＊＊＊＊＊＊
【質問】
例題の様に５×６マスが４つあり、その中を1~43の数字が重複有りで入っています。
　1つ目の５×６マス：A1~F5
　2つ目の５×６マス：H1~M5
　3つ目の５×６マス：A7~F11
　4つ目の５×６マス：H7~M11
使い方としては、
　(1)複写数欄と検索値欄それぞれに値を入れます。
　(2)複写数欄の数だけ、上記４つの5×6のセルを１塊りとして下にコピーする
　　（最大：43）。
　　検索値欄の検索値も１つコピーする。
　(3)コピー後に検索値欄の値でコピーした側の４つの5×6のセル内を検索して塗潰す。
　　具体的には、
　　(1)検索値と同じ値を見つけたら、黄色でセルを塗潰す。
　　(2)検索値と同じ値で隣接する８方向（上、下、左、右、右下、左下、右上、左上）
　　　　の数字との差が0か１なら、検索値とそのセルを赤色で塗潰す。

〇例題
　 Ａ　B　C　Ｄ　Ｅ　Ｆ　　G　Ｈ　Ｉ　Ｊ　Ｋ　Ｌ　Ｍ　
1　06　21　23　36　37　43　　01　08　16　31　35　41
2　07　12　14　23　32　43　　06　10　13　20　27　32
3　09　17　20　29　42　40　　02　15　18　30　34　38
4　03　05　13　25　27　41　　01　09　25　30　42　43
5　04　11　22　28　35　39　　11　16　18　24　29　42
6
7　03　17　27　36　40　41　　07　21　22　23　33　37
8　03　04　08　24　26　39　　02　03　07　14　18　38
9　10　12　22　32　37　42　　05　10　13　40　41　42
10　02　09　25　32　41　42　　07　13　22　40　41　42
11　08　14　23　24　30　39　　03　29　31　40　41　42

複写数：01　※最大1~43の数字が入る。
検索値：41　※最大43個の数字が右に並ぶ。

〇結果
　M1：41が黄色で塗潰される。
　E3、F3、F4　：40、41、42が赤色で塗潰される。
　E7、F7　　　：40、41が赤色で塗潰される。
　 F9、E10、F10：41、42、42が赤色で塗潰される。
　 K9、L9、M9、K10、L10、M10、K11、L11、M11：40、41、42が赤色で塗潰される。

〇注意事項
　・使用するエクセルは2010です。
　・セルの数字は表示上、2桁で表しています。（例：1ではなく01）
　・検索値欄に入力できる数字は最大43個で、1~43迄の数字です。
　・複写数欄に入力できる数字は1~43迄の１つです。

以上、よろしくお願いします。

回答No.2

watabe007 · ベストアンサー

>できれば、5×7マスが４つのケースも
複写数はQ1セル、検索値セルはQ2セルより右へ
としています。
Sub Test2()
Dim i As Long, myArea As Range
Dim myRang As Range, c As Range
Dim SV As Long, cc As Range, flg As Boolean

Application.ScreenUpdating = False
'作業行挿入
Rows("1:1").Insert
'作業列挿入
Columns("A:A").Insert
Range("B13:P528").Clear '【ここが変更】
For i = 1 To Range("R2").Value '【ここが変更】
Range("B2:P12").Copy Cells(i * 12 + 2, "B") '【ここが変更】
Set myArea = Cells(i * 12 + 2, "B").Resize(11, 15).SpecialCells(2) '【ここが変更】
Cells(3, i + 17).Copy Cells(i * 12 + 1, "B") '【ここが変更】
SV = Cells(i * 12 + 1, "B").Value
For Each myRang In myArea.Areas
For Each c In myRang
If Val(c.Value) = SV Then
For Each cc In Intersect(c.Offset(-1, -1).Resize(3, 3), myRang)
If Abs(Val(c.Value) - Val(cc.Value)) <= 1 _
And c.Address <> cc.Address Then
cc.Interior.Color = vbRed
flg = True
End If
Next cc
If flg = True Then
c.Interior.Color = vbRed
Else
c.Interior.Color = vbYellow
End If
End If
flg = False
Next c
Next myRang
Next i
'作業行削除
Rows("1:1").Delete
'作業列削除
Columns("A:A").Delete
ActiveCell.Activate
Application.ScreenUpdating = True
End Sub

お礼

いつも大変お世話になっています。
2つも回答いただきありがとうございます。

回答No.1

watabe007

こんばんは
複写数はM1セル、検索値セルはM2セルより右へ
としています。
Sub Test()
Dim i As Long, myArea As Range
Dim myRang As Range, c As Range
Dim SV As Long, cc As Range, flg As Boolean

Application.ScreenUpdating = False
'作業行挿入
Rows("1:1").Insert
'作業列挿入
Columns("A:A").Insert
Range("B13:L528").Clear
For i = 1 To Range("N2").Value
Range("B2:L12").Copy Cells(i * 12 + 2, "B")
Set myArea = Cells(i * 12 + 2, "B").Resize(11, 11).SpecialCells(2)
Cells(3, i + 13).Copy Cells(i * 12 + 1, "B")
SV = Cells(i * 12 + 1, "B").Value
For Each myRang In myArea.Areas
For Each c In myRang
If Val(c.Value) = SV Then
For Each cc In Intersect(c.Offset(-1, -1).Resize(3, 3), myRang)
If Abs(Val(c.Value) - Val(cc.Value)) <= 1 _
And c.Address <> cc.Address Then
cc.Interior.Color = vbRed
flg = True
End If
Next cc
If flg = True Then
c.Interior.Color = vbRed
Else
c.Interior.Color = vbYellow
End If
End If
flg = False
Next c
Next myRang
Next i
'作業行削除
Rows("1:1").Delete
'作業列削除
Columns("A:A").Delete
Application.ScreenUpdating = True
End Sub