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

質問

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

〇例題
　a　b　c　d　e　f　g　h　i　j　k　l　m　n
1 02 05 08 09 14 13 15 16 17 28 22 32 33 37
2 03 03 05 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 01 02 10 04 11 05 18 13 27 20 28 33 30 34
10 12 11 16 14 19 24 24 25 27 26 33 32 35 35

検索値: 07

【結果】
検索値に07を入れたら、下記の３マス（12セル）が塗潰される。
c3,d3,c4,d4
e3,f3,e4,f4
a7,b7,a8,b8

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

回答No.4

watabe007 · ベストアンサー

またまた整理しました。
Sub Test3()
　　Dim fnd As Range, R As Boolean, C As Boolean
　　Dim adr As String
　　Dim 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
　　　　fnd.Offset(R, C).Resize(2, 2).Interior.Color = vbYellow
　　　　Set fnd = Range("A1:N10").FindNext(fnd)
　　Loop While adr <> fnd.Address
End Sub

お礼

さっそくのご回答ありがとうございます。
Sub Test、Sub Test２のマクロで試しましたら
希望どおりの結果が得られて満足しております。
さらに、Sub Test3まで作って頂き、ありがとうございます。

回答No.3

watabe007

コードを整理しました。
Sub Test2()
　　Dim fnd As Range, R As Long, C As Long
　　Dim adr As String
　　Dim 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 = IIf(fnd.Row Mod 2 = 0, -1, 0)
　　　　C = IIf(fnd.Column Mod 2 = 0, -1, 0)
　　　　fnd.Offset(R, C).Resize(2, 2).Interior.Color = vbYellow
　　　　Set fnd = Range("A1:N10").FindNext(fnd)
　　Loop While adr <> fnd.Address
End Sub

回答No.2

watabe007

訂正です。m(_ _)m
Set fnd = Range("A1:N10").Find(What:=keyWord, LookIn:=xlValues, _
　　LookAt:=xlPart, SearchOrder:=xlByRows, MatchByte:=False)
　　↓　　　　　　　　↓　　　　　　　↓
Set fnd = Range("A1:N10").Find(What:=keyWord, LookIn:=xlValues, _
　　LookAt:=xlWhole, SearchOrder:=xlByRows, MatchByte:=True)

回答No.1

watabe007

マクロですが
検索値欄は、P1セルとしています。
Sub Test()
　　Dim fnd As Range, SP As Range
　　Dim adr As String
　　Dim keyWord As String

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