４つのセルを１つの塊り（マス）と捉えて塗潰す方法３

質問

どなたかご存知でしたら回答をよろしくお願いします。
【質問】
下図の様に、a～ｎ、１～１０の合計１４０個のセルに数字が１～９９迄の重複有りで
入っています。a1,a2,b1,b2の４つのセルで１つのマスとみなすと、
140個のセルは縦：５マス、横：７マスの合計３５マスとなります。
この条件で、検索値欄に１つ数字を入れたら、一致した数字が入っているマス
（４つのセルの集合）を塗潰すにはどうすればよいですか？
具体的には、
　　　(1)１つのマスに一致した数字が１個の場合は黄色く塗り潰す。
　　　(2)１つのマスに一致した数字が２個の場合は赤く塗り潰す。
　　　(3)１つのマスに一致した数字が３個の場合は緑色で塗り潰す。
　　　(4)１つのマスに一致した数字が４個の場合は青色で塗潰す。

〇例題
　a　b　c　d　e　f　g　h　i　j　k　l　m　n
1 02 05 07 07 14 13 15 16 17 28 22 32 33 37
2 03 03 07 14 13 28 99 31 23 32 31 36 32 37
3 05 01 07 06 15 07 20 08 26 12 27 19 32 37
4 04 03 08 10 10 14 12 17 24 18 30 22 37 24
5 08 01 13 02 16 04 25 09 28 15 34 24 36 34
6 01 06 05 12 18 14 22 19 23 30 26 35 28 36
7 02 03 04 11 06 16 20 21 25 26 29 27 31 29
8 07 07 08 10 09 14 17 15 18 21 19 26 20 34
9 07 07 10 04 11 05 18 13 27 20 28 33 30 34
10 07 07 16 14 19 24 24 25 27 26 33 32 35 35

検索値:07

【結果】
検索値に07を入れたら、下記の５マス（２0セル）が塗潰される。
c1,d1,c2,d2 ・・・ 3個一致なので、緑色で塗潰される。
c3,d3,c4,d4 ・・・　1個一致なので、黄色で塗潰される。
e3,f3,e4,f4　・・・　1個一致なので、黄色で塗潰される。
a7,b7,a8,b8　 ・・・2個一致なので、赤色で塗潰される。
a9,b9,a10,b10 ・・・４個一致なので、青色で塗潰される。

〇注意事項
　・使用するエクセルは２０１０です。
　・１マス＝４セルです。※a1,a2,b1,b2で１マスです。
　・セルに入っている数字はランダムで、同じ数字の重複は35マス（140セル）全体で
　　４個迄です（１つのマスに４個入る事も有るし、４つのマスに１個ずつ入る事も
　　あります。）
　・検索値欄に入力できる数字は１～９９迄の１つです。
　・セルの数字は表示上、２桁で表しています。（例：１ではなく０１）

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

回答No.1

watabe007 · ベストアンサー

こんばんは、
前回の回答では３個目は黄色に戻ってしまい、申し訳なかったです。m(_ _)m
Sub Test5()
Dim fnd As Range, R As Boolean, c As Boolean
Dim adr As String, keyWord As String

keyWord = Range("P1").Value
Range("A1:N10").Interior.Color = xlNone
Set fnd = Range("A1:N10").Find(What:=keyWord, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, MatchByte:=True)
If fnd Is Nothing Then
MsgBox keyWord & " は見つかりませんでした。", 48
Exit Sub
End If
adr = fnd.Address
Do
R = fnd.Row Mod 2 = 0
c = fnd.Column Mod 2 = 0
With fnd.Offset(R, c).Resize(2, 2).Interior
If .Color = vbYellow Then
.Color = vbRed
ElseIf .Color = vbRed Then
.Color = vbGreen
ElseIf .Color = vbGreen Then
.Color = vbBlue
ElseIf .Color = vbWhite Then
.Color = vbYellow
End If
End With
Set fnd = Range("A1:N10").FindNext(fnd)
Loop While adr <> fnd.Address
End Sub

お礼

いつも回答頂きありがとうございます。
早速、教えて頂きありがとうござます。
前回の回答の動作には気が付きませんでした。
また質問を見かけたらよろしくお願いします。
丸投げですが・・・。