同じ数字を2個使用している重複行の数字の出力方法

質問

いつもお世話になっております。
ご存じの方がお見えでしたら回答をよろしくお願い致します。
【質問】
　2019/12/08 22:31 に質問No.9687909　として
　『同じ数字を３個～４個使用している重複行の塗り潰し２』という質問をさせて
　頂き、SI299792様とnishi6様から回答を頂きました。
　この時の質問から発展して、『同じ数字を2個使用している重複行の数字の出力
　方法』が今回の質問です。添付図のとおり、５列×２０行に絞り、２個の数字が
　重複していたら黄色でセルを塗り潰し、”重複している行”をＧ列に書き出す事は
　前回の回答から対応できましたが、実際にどの２個の数字が重複しているか塗潰
　されたセルでは分かり難い場合があるため、Ｈ列～ＡＡ列に書き出す方法が知り
　たく質問させて頂きます。

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

回答No.1

nishi6 · ベストアンサー

以下になりました。添付図と同じ結果になりました。

Sub paintCell3()
　Dim num(20, 37) As Integer　　　 '// 数値
　Dim elmt(1) 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　　　　　　　 '// 一致フラグ（カウンタ）
　Dim WCol As Integer

　Range("B2:F21").Interior.Pattern = xlNone
　Range("G2:AA21").ClearContents
　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
　　　　　　If Flg = 1 Then
　　　　　　　elmt(0) = c
　　　　　　ElseIf Flg = 2 Then
　　　　　　　elmt(1) = c
　　　　　　End If
　　　　　End If
　　　　Next

　　　　'// セルを塗る
　　　　If Flg = 2 Then
　　　　　If .Offset(r, 6) = "" Then
　　　　　　.Offset(r, 6) = "'" & r2
　　　　　Else
　　　　　　.Offset(r, 6) = .Offset(r, 6) & "," & r2
　　　　　End If
　　　　　WCol = Application.Max(6, .Offset(r, 100).End(xlToLeft).Column)
　　　　　.Offset(r, WCol) = elmt(0)
　　　　　.Offset(r, WCol + 1) = elmt(1)

　　　　　If .Offset(r2, 6) = "" Then
　　　　　　.Offset(r2, 6) = "'" & r
　　　　　Else
　　　　　　.Offset(r2, 6) = .Offset(r2, 6) & "," & r
　　　　　End If
　　　　　WCol = Application.Max(6, .Offset(r2, 100).End(xlToLeft).Column)
　　　　　.Offset(r2, WCol) = elmt(0)
　　　　　.Offset(r2, WCol + 1) = elmt(1)

　　　　　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

お礼

いつも大変お世話になっております。
早速やってみて問題ない結果となりました。
ありがとうございました。