2個の数字をひと塊として同じ塊を探してセルの塗潰し

質問

いつもお世話になっております。
ご存じの方がお見えでしたら回答をよろしくお願い致します。
【質問】
　添付図の様に各列２行分の数字（破線で囲った部分）をひと塊と捉え、
　５列×２０行の中で同じ塊が重複して存在したら黄色に塗潰す方法が
　知りたいです。
【注意事項】
　・５列×２０行に入る数字は１～３１迄で重複してランダムに入ります。
　・ひと塊の重複は最低１つは存在します。
　・使用するエクセルは２０１６です。　

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

回答No.7

kkkkkm · ベストアンサー

No3の微妙な変更です
こちらの方が微妙に早いと思います。

Sub Test()
Dim c As Range, d As Range

Application.ScreenUpdating = False
For Each c In Range("A1:E20")
If c.Row Mod 2 = 1 Then
For Each d In Range("A1:E20")
If d.Row Mod 2 = 1 And c.Value = d.Value And c.Address <> d.Address _
And c.Offset(1, 0).Value = d.Offset(1, 0).Value Then
c.Resize(2, 1).Interior.Color = vbYellow
End If
Next
End If
Next
Application.ScreenUpdating = True
End Sub

お礼

何度も回答いただきありがとうございました。

回答No.6

noname#252332

訂正ですすみません。最後の行。
【誤】あと下と右にコピー
【正】あと下と右に書式をコピー

お礼

回答頂きありがとうございます。
関数でもできるのですね。
勉強になりました。

回答No.5

noname#252332

関数だけの方法を書いておきます。シートは汚れますが。

すぐ右に、上の数を100倍して下の数を加えた表を作ります。
G1は、=A1*100+A2
あと1行飛びに下にコピー。
右にコピー。

そのさらに右に、先ほど作った表の重複する数の表を作ります。
M1は、=COUNTIF($G$1:$K$19,G1)
M2は、=COUNTIF($G$1:$K$19,G1)
あと下と右にコピー。

最初の表に戻って、ホームタブの条件付き書式で新しいルールで「数式を使用して、書式設定するセルを決定」で、
A1の条件付き書式は、=M1>1
あと下と右にコピー

この投稿のマルチメディアは削除されているためご覧いただけません。

回答No.4

imogasi

補足してほしい。
（A）２行分のセルの値を考える
（B)隣接したセルの値を考える
ようだが
ーー
（１）隣接したセル（縦方向らしい）縦２セルで６－２を考えるとき、順序が逆の、２（上のセル）６　（下のセル）は対と考えるのか？
（２）第三のペアーは存在するとするのか？
（３） 2セルのマスを考えたとき、６－２（隣接２セル）とｘ－6,２－Y（隣接マス、４セルの中）（X,Yは何でも）は該当すると考えるのか？
（上下２セルの組み合わせは固定か？便宜的なものか？）
ーー
関数では複雑になり、VBAでやらざるを得ないような気がする。

補足

回答頂きありがとうございます。
１）６-２の逆となる2-6はペアになりません。
２）第３のペアというのがいまいちわかりませんが、添付図に示したとおり、5列×２０行の中に
　　6-2という組み合わせ（重複）がある分、セルを塗り潰します。
３）６－２（隣接２セル）とｘ－6,２－Yは、別の組み合わせと考えます。

回答No.3

kkkkkm

No1の訂正です。
質問の添付図と同じ結果となります。

Sub Test()
Dim c As Range, d As Range
Application.ScreenUpdating = False
For Each c In Range("A1:E20")
For Each d In Range("A1:E20")
If c.Row Mod 2 = 1 And c.Value = d.Value And c.Address <> d.Address _
And c.Offset(1, 0).Value = d.Offset(1, 0).Value Then
c.Resize(2, 1).Interior.Color = vbYellow
End If
Next
Next
Application.ScreenUpdating = True
End Sub

回答No.2

kkkkkm

No1は勘違い
1列2行ずつのブロックと気がつきませんでした。

回答No.1

kkkkkm

VBAで以下でいかがですか。
なお追加で
A2A3とA8A9　1と6
A12A13とB4B5　3と9
E6E7に　6と2
が重複しています。

Sub Test()
Dim c As Range, d As Range
Application.ScreenUpdating = False
For Each c In Range("A1:E20")
For Each d In Range("A1:E20")
If c.Value = d.Value And c.Address <> d.Address _
And c.Offset(1, 0).Value = d.Offset(1, 0).Value Then
c.Resize(2, 1).Interior.Color = vbYellow
End If
Next
Next
Application.ScreenUpdating = True
End Sub

お礼

早速のご回答頂きありがとうございます。
A2A3とA8A9　1と6
A12A13とB4B5　3と9
E6E7に　6と2　が新たに黄色になるのも質問文とは違いますが参考になります。