検索値が隣どうしの場合に黄色に塗潰されない。

質問

いつもお世話になっております。
どかたかご存知でしたら回答をお願いします。
QNo.9570997　で2018/12/25に質問させて頂き
昨日、回答を頂きましたが、１か所不具合があり修正したいですが
自力では無理なので再度質問させて頂きます。
◆不具合内容
　下記の”不具合がでるパターン”はその下にある”〇例題”の
　A2：02→01　※A1とA2の値が01となる。
　A5：07→01
　の２か所の値を変更したものです。
＞複写数：01　
＞検索値：01　
　で、検索した場合、Ａ２に０１がありますが黄色に塗る潰されず
　Ａ１の０１と、Ａ５の０１が塗り潰されます。
　Ａ２の０１を黄色に塗潰すにはどうすればよいですか？
　同じ値が隣同士に存在するといずれか１つしか黄色に塗潰されないです。

　それ以外の機能は問題ありません。

〇不具合が出るパターン
　Ａ　B　C　Ｄ　Ｅ　Ｆ　G　Ｈ　Ｉ　Ｊ　Ｋ　Ｌ　Ｍ
1 01　11　16　26　31　40　　08　15　21　25　30　35
2 01　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 01　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

◆回答頂いたソース
Option Explicit

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
'
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

＊＊＊　2018/12/25　の質問　＊＊＊
【改造】検索値と一緒に出ている隣接数字を知るには？

いつもお世話になっております。
どかたかご存知でしたら回答をお願いします。
１ケ月程前に下記の質問をさせていただきました。
そして回答を頂きました。これを改造したく質問します。
尚、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を青色で塗潰す。

回答No.1

SI299792 · ベストアンサー

どかたかと言わず、現在「このユーザに質問する」があるので私に質問すればよかったのに。多分このプログラムは、私にしか直せません、他の人が答える場合、このプログラムを無視して、新しく作ると思います。
　前の質問のアドレスを載せれば、プログラムを直接乗せる必要はないと思います。無駄に質問が長くなるだけです。
'
Option Explicit
'
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
'
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
'　 差が１で重複の場合、紫にする。気に入らなければここをコメントにする。
　　　　If Cell1.Interior.Color <> vbRed Then '
　　　　ElseIf TableC(Cell1) = Count Then　　 '
　　　　　　Cell1.Interior.Color = vbMagenta　'
　　　　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 Integer
　　Dim ColF As Integer
'
　　RowF = Cell1.Row > 1
　　ColF = Cell1.Column > 1
'
　　For Each Cell2 In Cell1.Offset(RowF, ColF).Resize(2 - RowF, 2 - ColF)
　　　　RowF = Val(Cell2)
'
　　　　If Cell2 < "01" Then
　　　　ElseIf Abs(Cell1 - Cell2) = 1 Then
　　　　　　Cell2.Interior.Color = vbRed
　　　　ElseIf Cell1 = Cell2 Then
　　　　ElseIf Cell1.Address <> Cell2.Address Then
　　　　　　Cell2.Interior.Color = vbBlue
　　　　End If
　　　　TableC(RowF) = TableC(RowF) + 1 + TableB(RowF)
　　　　TableB(RowF) = True
　　Next Cell2
End Sub

　前のプログラムが気に入らず、勝手に新しい機能をつけました。差が１の場合、全てに重複があるかどうか判らない。この場合、青と赤の中間、マゼンタにしました。赤のままの方がよければ、右に’がついている所をコメントにして下さい。
　実は、不具合を知らせる為に、あなた宛てに質問したのですが、連絡は来ていませんか。もしそうなら「このユーザに質問する」は機能していないこという事です（OKWAVEではよくある事です）。すみませんが、連絡が来ているかどうか確認していただけますか。
　もう１つ、１ケ月程前の質問（青が付いていない）が気になります。よければアドレスを載せて下さい。
　あなた宛ての質問は、不要になったので削除しました。

お礼

回答頂きありがとうございます。
最初に回答頂いた後の確認不足でした。
再度、頂いた回答で修正されている事を確認しました。
新しい機能を付けて頂き、より区別しやすくなりました。
活用させて頂きます。
＞実は、不具合を知らせる為に、あなた宛てに質問したのですが、連絡は来ていませんか。もしそうなら「このユーザに質＞問する」は機能していないこという事です（OKWAVEではよくある事です）。すみませんが、連絡が来ているかどうか＞確認していただけますか。
>もう１つ、１ケ月程前の質問（青が付いていない）が気になります。よければアドレスを載せて下さい。

この質問はＯＫＷＥＢではなくBIGLOBEからさせて頂いてます。
「このユーザーに質問する」という機能は無いですし、私宛の連絡も来ていないです。
また、アドレスを載せる方法も無いです。

次回からは頂いた回答の確認に時間を取ってから質問を締め切るようにします。
このたびはありがとうございました。