【改造】検索値と一緒に出ている隣接数字を知るには？

質問

いつもお世話になっております。
どかたかご存知でしたら回答をお願いします。
１ケ月程前に下記の質問をさせていただきました。
そして回答を頂きました。これを改造したく質問します。
尚、5×6マス以外に、5×5マス、5×7マスへの改造方法も教えて頂けると助かります。

◆改造（付け加える）要件・・・下記以外は前回と同じです。
　(3)コピー後に検索値欄の値でコピーした側の４つの5×6のセル内を検索して塗潰す。
　　具体的には、
　(1)検索値と同じ値を見つけたら、黄色でセルを塗潰す。【既存】
　(2)検索値と同じ値で隣接する８方向（上、下、左、右、右下、左下、右上、左上）
　　の数字との差が0か１なら、検索値とそのセルを赤色で塗潰す。【既存】
　(3)検索値と同じ値で隣接する８方向（上、下、左、右、右下、左下、右上、左上）
　　の数字が全て同じなら、青く塗り潰す。【追加】
〇例題
　Ａ　B　C　Ｄ　Ｅ　Ｆ　G　Ｈ　Ｉ　Ｊ　Ｋ　Ｌ　Ｍ
1 01　11　16　26　31　40　　08　15　21　25　30　35
2 02　03　06　17　27　41　　01　11 　26 　28　31　36
3 04　09　12　19　22　42　　02　03 　06 　16　17　37
4 05　13　14　23　29　43　　04　09 　12 　22　27　38
5 07　10　18　20　24　27　　05　13 　19 　23　29　39
6
7 04　13　16　30　31　33　　05　08　20　22　26　37
8 02　15　17　24　29　34　　01　03　07　18　19　38
9 01　03　07　19　25　35　　04　12　14　16　25　39
10 11　12　14　21　27　36　 10 　11　21　23　27　40
11 06　09　10　23　28　37　 06 　08　09　20　28　41

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

〇結果
　A1、H2、A9、H8：01が黄色で塗潰される。
　A2、H3、A8　　 ：02が赤色で塗潰される。
　B2、I3、B9、I8　：03が青色で塗潰される。
〇青色を塗潰す説明
　A1にある01の隣接数字は小さい順に、02、03、11
　H2にある01の隣接数字は小さい順に、02、03、08、11、15
　A9にある01の隣接数字は小さい順に、02、03、11、12、15
　H8にある01の隣接数字は小さい順に、03、04、05、08、12
　01が見つかった４か所全てに出現している隣接数字は03なので03を青色で塗潰す。
　逆に03を検索値とした場合は、
　B2にある03接数字は小さい順に、01、02、04、06、09、11、12、16
　I3にある03隣接数字は小さい順に、01、02、04、06、09、11、12、26
　B9にある03隣接数字は小さい順に、01、02、07、11、12、14、15、17
　I8にある0の隣接数字は小さい順に、01、04、05、07、08、12、14、20
　03が見つかった４か所全てに出現している隣接数字は01、12なので、
　01、12を青色で塗潰す。

＊＊＊＊2018/11/21の質問の内容＊＊＊＊
【質問】
例題の様に５×６マスが４つあり、その中を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

SI299792 · ベストアンサー

検索値の数を数えれば、複写数はいらないと思うのですが。
複写数：Q1
検索値：Q2から右へ
に直しました。
複写数と検索値の数が合わない場合の動作保証はしません。
'
Sub Macro1()
'
　　Dim Col As Integer
　　Dim IRange As Range
'
　　Cells.Interior.Pattern = xlNone
　　[A13:O557].ClearContents
'
　　For Col = 0 To [Q1] - 1
　　　　Set IRange = [A1:O11].Offset(Col * 13)
　　　　IRange = [A1:O11].Value
　　　　Level1 IRange, Cells(2, Col + 17)
　　Next Col
End Sub

サブルーチンは前と同じ

お礼

早速の回答ありがとうございます。
また、ワガママを聞いてください重ねてありがとうございます。
得たい結果となりました。
また、質問を見かけたら回答頂けると助かります。

回答No.1

SI299792

面白そうなので作ってみました。

前の質問のアドレスが書いてありません。
しかも質問履歴が非公開になっています。
前のプログラムが判らないので、検索値の指定方法は独自です。

まず、Ｑ列１行目に「検索値」と入れて下さい。（タイトルなのでなくてもいい）
Ｑ列２行目から、検索値を入れます。
検索値の数だけコピーして実行します。

A1～O11 を範囲にしてあるので、改造なしで、５×７まで行けます。データのない所は空白にしておけばいいです。
青と赤がダブる場合、（差が１しかなく、隣接する全てに存在した場合）、赤を優先しています。
'
Option Explicit
'
Sub Macro1()
'
　　Dim Row As Integer
　　Dim RowCpy As Integer
　　Dim IRange As Range
'
　　Cells.Interior.Pattern = xlNone
　　[A13:O557].ClearContents
'
　　For Row = 2 To Cells(Rows.Count, "Q").End(xlUp).Row
　　　　RowCpy = Row - 2
　　　　Set IRange = [A1:O11].Offset(RowCpy * 13)
　　　　IRange = [A1:O11].Value
　　　　Level1 IRange, Cells(Row, "Q")
　　Next Row
End Sub
'
Sub Level1(IRange As Range, ByVal Search As Integer)
'
　　Dim Cell1 As Range
　　Dim TableC(43) As Integer
　　Dim Count As Integer
'
　　For Each Cell1 In IRange
'
　　　　If Cell1 = Search Then
　　　　　　Count = Count + 1
　　　　　　Level2 Cell1, TableC(), Search
　　　　　　Cell1.Interior.Color = vbYellow
　　　　End If
　　Next Cell1
'
　　For Each Cell1 In IRange
'
　　　　If Cell1.Interior.Color <> vbBlue Then
　　　　ElseIf TableC(Cell1) < Count Then
　　　　　　Cell1.Interior.Pattern = xlNone
　　　　End If
　　Next Cell1
End Sub
'
Sub Level2(Cell1 As Range, TableC() As Integer, Search As Integer)
'
　　Dim Cell2 As Range
　　Dim TableB(43) As Boolean
　　Dim RowF As Boolean
　　Dim ColF As Boolean
'
　　RowF = Cell1.Row > 1
　　ColF = Cell1.Column > 1
'
　　For Each Cell2 In Cell1.Offset(RowF, ColF).Resize(2 - RowF, 2 - ColF)
'
　　　　If Cell2 < "01" Then
　　　　ElseIf Abs(Cell1 - Cell2) = 1 Then
　　　　　　Cell2.Interior.Color = vbRed
　　　　ElseIf Cell1.Address <> Cell2.Address Then
　　　　　　Cell2.Interior.Color = vbBlue
　　　　　　TableC(Cell2) = TableC(Cell2) + 1 - TableB(Cell2)
　　　　　　TableB(Cell2) = True
　　　　End If
　　Next Cell2
End Sub

実際にやってみたら、
33,34,42,43
のように、１か所しかない場合、周り全部青になりました。
１か所なら見つかった１か所全てに出現している事になります。

補足

早速の回答ありがとうございます。
教えて頂いたソースを貼って実行したところやりたいことができました。
お願いばかりして恐縮ですが、
教えて頂いたソースでは、
Ｑ２から下に検索値を入れた分だけコピーしながら、
検索する動きですが、質問文にも書いてますが、
複写数と検索値を分けた場合はどのようなソースになりますか？

＞複写数：※入力すると、入力値-1で下にコピーされる。最大1~43の数字が入る。
＞検索値：※最大43個の検索数字が右に並ぶ。

下記の例では、複写数が03なので、コピー元から同じ内容で2つ下にコピーされた後に、
１つ目を検索値15で検索、２つ目を検索値の30で検索、３つ目を検索値の43で検索する。
例）
　複写数：03
　検索値：15　30　43