塗潰されたセルと同じ色の数字同士を抽出して並べる2

質問

いつもお世話になっております。
ご存じの方がお見えでしたらご回答をよろしくお願いします。
※特に、SI299792　様よろしくお願いします。
【質問】
　昨日、こちらで質問させて頂きました「塗潰されたセルと同じ色の数字同士を
　抽出して並べる」（2020/06/06 14:19 質問No.9757677）の改造版の質問です。
　添付図のとおり、昨日の質問とは異なり5×5が4マスではなく、
　5×6が４マスありこれを１つとして、S1の数だけ下に複写して
　S2の数字で5×6が４マスの中を検索して、
　下記のとおり該当するセルを塗り潰します。
　　・検索値・・・・黄色
　　・検索値の±１の数字・・・赤色
　　・検索値と同じ数だけ周りにある数字・・・緑色
　　・検索値より１つ少ない数だけ周りにある数字・・・青色
　ここまでの質問は（2018/12/30 09:06 質問No.9572759 ）にさせて頂き、
　SI299792様にＶＢＡのソースを頂きました。
　（SI299792様に怒られると思うのでソースはここには載せません。）
　この状態だと、Ｐ列にある４色（黄色、青色、赤色、緑色）の右側に
　左側の同じ色で塗潰された数字を左から昇順に並べる事ができません。
　添付図の様にするにはどうすればよいですか？

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

回答No.2

SI299792

ずみません、前回のプログラムを解析した結果、バグがありました。
これは前プログラムで色を付けたものですね、
検索値２の時、15に色が付いているのはその為で、私のミスです。

＞私が１桁入力に変更はしていないと思います。
前回は、
1 01　11　16　26　31　40　　08　15　21　25　30　35
と、必ず２桁で、１桁の場合、頭に０をつけていました。
今回は頭に０が付いていません。
＞以下ソースを貼ります。
欲しいのは、ソースではなく、数値データです。
6 15 22 31 41 43…
︙

申し訳ありません、これ以上無償でできません。今OKWAVEにはビットコインでの支払いシステムがあるので、今回料金は.001ビットコイン（約￥1000）とさせていただきます。

回答No.1

SI299792

こんな難しいの無理、お断りします。と思ったら、昔作っていましたね。
我ながら、よくこんなの作ったな、若気の至りですね。
もう破棄してしまい、覚えてもいないので、何とかプログラムを解析してみました。
すると問題点が。

(1) 数えるのも色を付けるのも、検索文字の周りの文字だけが対象になっています。　
これでいいですか。

(2) 条件が重複することがあります。
検索値±１で、検索値と同じ数だけ周りにある
検索値±１で、検索値より１つ少ない数だけ周りにある
つまり、青と赤、赤と緑、は被るる可能性があります。
前プログラムは、これらを色分けして６色使っていました。どの条件を優先しますか。それとも、被った場合両方に出しますか。
また、これは、直せないかもしれない（直したくない）ので別々の色のままでもいいですか。

(3) 前回は、必ず２桁で文字形式でした。変わったのですか。

今回のサンプルにも疑問が、
(1) 検索値１の時、A3,H10にも２がありますが、ここは１の周りにないので色を付けないのですね。

(2) 検索値１の時、１の周りに２が２つという事は緑の条件も満たしています。（周り以外も数えるのなら４つになるので条件に合いませんが）という事は、赤優先ですか。

(3) 検索値２の時、２は４つあります、15は２つしかありません。しかし出力されています。よく見ると、D25 にも15があります。これも数えるのですか。だとしたら、前プログラムは使えません。

(4) 前の様に、直接データをテキストでコピペしていただけませんか。入力が大変です。

参考URL：

https://okwave.jp/qa/q9572759.html

補足

お返事頂きありがとうございます。以下、ご質問の回答です。
（1）数えるのも色を付けるのも、検索文字とその周りの文字を対象にお願いします。
（2）別々の色のままでもよいです。
（3）２桁の文字入力でしたか、でも最初に回答を頂いたソースそのままで今回の添付図作成
　　　してます。私が１桁入力に変更はしていないと思います。
サンプルへの質問
(1) 1の周りに無い２には色は付けません。
(2)赤優先です。
(3)D25にある15は数えません。あくまで、検索値：２と隣接する数字で、登場回数が検索値-1の場合は緑色です。（２は4回、１５は２回ではなく３回（I20にある15はH20,I21の隣接数字）です。）
(4)以下ソースを貼ります。
'
Option Explicit
'
Sub Macro1()
'
Dim Col As Integer
Dim IRange As Range
'
Cells.Interior.Pattern = xlNone
[A13:Q557].ClearContents
'
For Col = 0 To [S1] - 1
Set IRange = [A1:O11].Offset(Col * 13)
IRange = [A1:O11].Value
Level1 IRange, Cells(2, Col + 19)
Cells(Col * 13 + 1, "P") = "検索値"
Cells(Col * 13 + 1, "Q") = Cells(2, Col + 19)
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 - 1 Then
Cell1.Interior.Color = vbGreen
ElseIf TableC(Cell1) < Count Then
Cell1.Interior.Pattern = xlNone
End If
'
If Cell1.Interior.Color <> vbRed Then
ElseIf TableC(Cell1) = Count - 1 Then
Cell1.Interior.Color = &HFF7F&
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
Cell2.Interior.Color = vbBlue
End If
TableC(RowF) = TableC(RowF) + 1 + TableB(RowF)
TableB(RowF) = True
Next Cell2
End Sub