同じ数字を３個～４個使用している重複行の塗り潰し

質問

いつもお世話になっております。
ご存じの方がお見えでしたら回答をよろしくお願い致します。
【質問】
　添付図の様にA行～Ｔ行の第一数字から第五数字まで１から３１の数字が重複して　入っています。（１行だけで見れば重複はしておらず、第一数字から昇順に第五数　字まで並んでいます。）初めにＡ行からＢ行～Ｔ行を１行ずつ見ていき、
　Ａ行の５つの数字のうち３個～４個同じ数字を使用している行があればどちらの行
　の数字も黄色に塗り潰す、次にＢ行からＣ行～Ｔ行を１行ずつ見ていき・・・
　と、最後はＳ行からＴ行を見るまでを繰り返し、５つの数字のうち３個～４個
　同じ数字を使用している行があればどちらの行の数字も黄色に塗りつぶす方法が
　知りたいです。
　◎添付図の結果として黄色に塗り潰される行は
　　(1)A行とG行・・・２、７、１９、２３が重複
　　(2)Ｂ行とH行・・・３、６、１４，２２が重複
　　(3)C行とＩ行・・・４，１５、１７，２１が重複
　　(4)Ｄ行とＪ行・・・８、９、１８、２５が重複
　　(5)Ｍ行とＱ行・・・１２，１４、２３，２８が重複
　　(6)Ｎ行とＳ行・・・５，１９，３１が重複
　　(7)Ｏ行とＴ行・・・１，６，２１が重複

【注意事項】
　　・使用するエクセルは2016です。
　　・Ａ行～Ｔ行に入る数字は毎回異なります。
　　　但し使用数字は１～３１で、１行でみれば重複無しで左から昇順です。
　　・３個～４個の数字が重複する行が存在しないことはありません。

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

回答No.2

SI299792 · ベストアンサー

このプログラムでできますが、どの行が重複するか判りません。
(1)をコメントにして(2)のコメントを外してみて下さい。面白いですよ。
(3)のコメントを外すと、Ｇ列に一致する列が出力されます。
'
Option Explicit
'
Sub Macro1()
'
　　Dim Row1 As Long
　　Dim Row2 As Long
　　Dim Count As Integer
　　Dim Same1(2 To 6) As Boolean
　　Dim Same2(2 To 6) As Boolean
　　Dim Col As Integer
　　Dim What As Integer
　　Dim Find As Range
'
　　Cells.Interior.Pattern = xlNone
'
　　For Row1 = 2 To [B1].End(xlDown).Row
'
　　　　For Row2 = Row1 + 1 To [B1].End(xlDown).Row
　　　　　　Count = 0
　　　　　　Erase Same1
　　　　　　Erase Same2
'
　　　　　　For Col = 2 To 6
　　　　　　　　What = Cells(Row1, Col)
　　　　　　　　Set Find = Range("B" & Row2, "F" & Row2). _
　　　　　　　　　　Find(What, LookIn:=xlValues, LookAt:=xlWhole)
'
　　　　　　　　If Not Find Is Nothing Then
　　　　　　　　　　Count = Count + 1
　　　　　　　　　　Same1(Col) = True
　　　　　　　　　　Same2(Find.Column) = True
　　　　　　　　End If
　　　　　　Next Col
'
　　　　　　If Count = 3 Or Count = 4 Then
'
　　　　　　　　For Col = 2 To 6
'
　　　　　　　　　　If Same1(Col) Then
　　　　　　　　　　　　Cells(Row1, Col).Interior.Color = vbYellow '(1)
'　　　　　　　　　　　　Cells(Row1, Col).Interior.ColorIndex = Row1 + 1'(2)
　　　　　　　　　　End If
'
　　　　　　　　　　If Same2(Col) Then
　　　　　　　　　　　　Cells(Row2, Col).Interior.Color = vbYellow　'(1)
'　　　　　　　　　　　　Cells(Row2, Col).Interior.ColorIndex = Row1 + 1’(2)
　　　　　　　　　　End If
　　　　　　　　Next Col
'　　　　　　　　Cells(Row1, "G") = Row2 '(3)
'　　　　　　　　Cells(Row2, "G") = Row1 '(3)
　　　　　　End If
　　　　Next Row2
　　Next Row1
End Sub

お礼

回答いただきありがとうございます。
同じ黄色だけだとどれと重複してるかわかりにくくなるため色分け
と一致行を出すという案は思いつきませんでした。
カラフル行で区別しやすくなりました。
ありがとうございました。

回答No.1

nishi6

マクロを作ってみました。ループのお化けです。工夫できそう？
結果は添付図と同じになりました。当方、win10、Excel2010です。

Sub paintCell()
　Dim num(20, 31) As Integer　　　 '// 数値
　Dim r As Integer, r2 As Integer　'// 行カウンタ
　Dim c As Integer, c2 As Integer, c3 As Integer　'// 列カウンタ
　Dim n As Integer　　　　　　　　 '// 数字
　Dim Flg As Integer　　　　　　　 '// 一致フラグ（カウンタ）

　With Range("A1")
　　'// 値を取り込む
　　For r = 1 To 20
　　　For c = 1 To 5
　　　　n = .Offset(r, c)
　　　　num(r, n) = 1
　　　Next
　　Next

　　For r = 1 To 19
　　　'// 一致のカウント
　　　For r2 = r + 1 To 20
　　　　Flg = 0
　　　　For c = 1 To 31
　　　　　If num(r, c) = 1 And num(r2, c) = 1 Then
　　　　　　Flg = Flg + 1
　　　　　End If
　　　　Next

　　　　'// セルを塗る
　　　　If Flg = 3 Or Flg = 4 Then
　　　　　For c2 = 1 To 5
　　　　　　For c3 = 1 To 5
　　　　　　　If .Offset(r, c2) = .Offset(r2, c3) Then
　　　　　　　　.Offset(r, c2).Interior.ColorIndex = 6
　　　　　　　　.Offset(r2, c3).Interior.ColorIndex = 6
　　　　　　　End If
　　　　　　Next
　　　　　Next
　　　　End If
　　　Next
　　Next
　End With
End Sub

お礼

早速のご回答いただきありがとうございます。
やってみて、やりたい結果になりました。
ソースにコメントもついて頂き、改造もしやすいです。
ありがとうございました。