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

質問

いつもお世話になっております。
ご存じの方がお見えでしたら回答をよろしくお願い致します。
【質問】
　2019/09/29 22:13 に質問No.9662014 として、
　『同じ数字を３個～４個使用している重複行の塗り潰し』という質問をさせて
　頂きました。その時に、SI299792様とnishi6様から回答を頂きました。
　この時の質問は５列×２０行でしたが、
　今回は添付図のとおり、７列×３０行に増やした場合の改造の仕方を
　知りたく質問させていただきます。その他条件は前回の質問（質問No.9662014
　と同じです。

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

回答No.4

nishi6 · ベストアンサー

＞Ｉ行（重複する行）に重複している行をつけるには

Sub paintCell2()
　Dim num(30, 37) 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 30
　　　For c = 1 To 7
　　　　n = .Offset(r, c)
　　　　num(r, n) = 1
　　　Next
　　Next

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

　　　　'// セルを塗る
　　　　If Flg = 3 Or Flg = 4 Then
　　　　　If .Offset(r, 8) = "" Then
　　　　　　.Offset(r, 8) = "'" & r2
　　　　　Else
　　　　　　.Offset(r, 8) = .Offset(r, 8) & "," & r2
　　　　　End If
　　　　　If .Offset(r2, 8) = "" Then
　　　　　　.Offset(r2, 8) = "'" & r
　　　　　Else
　　　　　　.Offset(r2, 8) = .Offset(r2, 8) & "," & r
　　　　　End If

　　　　　For c2 = 1 To 7
　　　　　　For c3 = 1 To 7
　　　　　　　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

お礼

重複する行をつけてくださりありがとうございます。
添付いただいた結果と同じになりました。

回答No.3

SI299792

済みません。コピペミスでプログラム名が消えました。頭は、
'
Option Explicit
'
Sub Macro1()
'
にして下さい。以降はそのままです。

回答No.2

SI299792

列数の自動判断を付けました。行数、列数が増えても、プログラムの変更の必要はありません。
前回のnishi6さんのプログラムを参考に、実行速度を上げました。
その代わり、最大値は31です。最大値が大きくなる場合、To 31 の数を増やして下さい。
前回同様、黄色でなく、カラフルにしました。
３か所以上重複がある場合、どうするか書いてありません。そのまま色を付けています。その為、５か所以上色が付くことがあります。
なお、入力が面倒なので、このデータでは試していません。
'
Option Explicit
'
　　Dim Row1 As Long
　　Dim Row2 As Long
　　Dim Count As Integer
　　Dim CEnd As Integer
　　Dim Col1 As Integer
　　Dim Col2 As Integer
　　Dim Index As Integer
　　Dim Find1(1 To 31) As Integer
　　Dim Find2(1 To 31) As Integer
'
　　CEnd = [B1].End(xlToRight).Column
　　Cells.Interior.Pattern = xlNone
　　Cells(2, CEnd).Resize(Rows.Count - 1).ClearContents
'
　　For Row1 = 2 To [B1].End(xlDown).Row - 1
'
　　　　For Row2 = Row1 + 1 To [B1].End(xlDown).Row
　　　　　　Count = 0
　　　　　　Erase Find1
　　　　　　Erase Find2
'
　　　　　　For Col1 = 2 To CEnd - 1
　　　　　　　　Index = Cells(Row1, Col1)
　　　　　　　　Find1(Index) = Col1
　　　　　　　　Index = Cells(Row2, Col1)
　　　　　　　　Find2(Index) = Col1
　　　　　　Next Col1
'
　　　　　　For Index = 1 To 31
　　　　　　　　Col1 = Find1(Index)
　　　　　　　　Col2 = Find2(Index)
　　　　　　　　Count = Count - (Col1 * Col2 > 0)
　　　　　　Next Index
'
　　　　　　If Count = 3 Or Count = 4 Then
'
　　　　　　　　For Index = 1 To 31
　　　　　　　　　　Col1 = Find1(Index)
　　　　　　　　　　Col2 = Find2(Index)
'
　　　　　　　　　　If Col1 * Col2 > 0 Then
　　　　　　　　　　　　Cells(Row1, Col1).Interior.ColorIndex = Row1 + 1
　　　　　　　　　　　　Cells(Row2, Col2).Interior.ColorIndex = Row1 + 1
　　　　　　　　　　End If
　　　　　　　　Next Index
　　　　　　　　Cells(Row1, CEnd) = Cells(Row1, CEnd) & " " & Row2 - 1
　　　　　　　　Cells(Row2, CEnd) = Cells(Row2, CEnd) & " " & Row1 - 1
　　　　　　End If
　　　　Next Row2
　　Next Row1
End Sub

お礼

いつもお世話になっております。
＞行数、列数が増えても、プログラムの変更の必要はありません。
今後を見据えて対応してくださりありがとうございます。
上手く動きました。

回答No.1

nishi6

黄色が沢山になりました。

Sub paintCell()
　Dim num(30, 37) 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 30
　　　For c = 1 To 7
　　　　n = .Offset(r, c)
　　　　num(r, n) = 1
　　　Next
　　Next

　　For r = 1 To 29
　　　'// 一致のカウント
　　　For r2 = r + 1 To 30
　　　　Flg = 0
　　　　For c = 1 To 37
　　　　　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 7
　　　　　　For c3 = 1 To 7
　　　　　　　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

補足

回答いただきありがとうございます。
確かに”ほぼ黄色”ですね。
追加で質問して申し訳ありませんが、
どの行と重複しているか判別するために
Ｉ行（重複する行）に重複している行をつけるにはどうすればよいですか？