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

質問

いつも大変お世話になっております。
どなたかご存じの方がお見えでしたら回答頂けると幸いです。
【質問】
2020/02/29 15:35に質問No.9718103として
『同じ数字を2個使用している重複行の数字の出力方法２』という質問を
させて頂き、SI299792様から回答を頂きました。
動作としては添付図のとおり５列×２０行の数字の中から、
２個の数字が重複していたら黄色でセルを塗り潰し、
重複する行に重複した行を実際に重複した２個の数字をＨ列～ＡＡ列に書き出し、
重複数字１～重複数字１０の２列×２０行の数字をＡＢ列・ＡＣ列に縦に並べた後、
昇順に並び変えて重複数字を削除し、重複数字１～重複数字１０の２列×２０行の数字をＡＥ列のみに縦に並べた後、昇順に並び変えて重複数字を削除する。
ここから今回の質問です。
(1)ＡＢ列・ＡＣ列に縦に並べた後、昇順に並び変えて重複数字を削除されるはずですが、添付図のとおりAB19・AC19、AB21・AC21に「22　30」が残っています。
この重複を削除するにはどうすればよいですか？

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

回答No.1

SI299792 · ベストアンサー

本当だ。バグってた。
Option Explicit
Option Base 1
'
Sub Macro1()
　　Const Max = 31
　　Dim Cell As Range
　　Dim Points(2 To 21, Max) As Integer
　　Dim Row1 As Integer
　　Dim Row2 As Integer
　　Dim Col1 As Integer
　　Dim Col2 As Integer
　　Dim Index As Integer
　　Dim Count As Integer
　　Dim Col1S(5) As Integer
　　Dim Col2S(5) As Integer
'
　　[B:F].Interior.Pattern = xlNone
　　[G2:AA21].ClearContents
　　[AB:AE].ClearContents
　　Application.ScreenUpdating = False
'
　　For Each Cell In [B2:F21]
　　　　Points(Cell.Row, Cell) = Cell.Column
　　Next Cell
'
　　For Row1 = 2 To 21
'
　　　　For Row2 = Row1 To 21
　　　　　　Count = 0
'
　　　　　　For Index = 1 To Max
　　　　　　　　Col1 = Points(Row1, Index)
　　　　　　　　Col2 = Points(Row2, Index)
'
　　　　　　　　If Col1 > 0 And Col2 > 0 Then
　　　　　　　　　　Count = Count + 1
　　　　　　　　　　Col1S(Count) = Col1
　　　　　　　　　　Col2S(Count) = Col2
　　　　　　　　End If
　　　　　　Next Index
'
　　　　　　If Count = 2 Then
　　　　　　　　ColorPoint Row1, Row2, Col1S(1), Col1S(2)
　　　　　　　　ColorPoint Row2, Row1, Col2S(1), Col2S(2)
　　　　　　　　Col1 = Col1S(1)
　　　　　　　　Col2 = Col1S(2)
　　　　　　　　Col1 = Cells(Row1, Col1)
　　　　　　　　Col2 = Cells(Row1, Col2)
　　　　　　　　Index = Col1 * Max + Col2 - Max
　　　　　　　　Cells(Index, "AB") = Col1
　　　　　　　　Cells(Index, "AC") = Col2
　　　　　　　　Cells(Col1, "AE") = Col1
　　　　　　　　Cells(Col2, "AE") = Col2
　　　　　　End If
　　Next Row2, Row1
　　[AB:AE].SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End Sub
'
Sub ColorPoint _
　　(RowA As Integer, RowB As Integer, ColA As Integer, ColB As Integer)
　　Dim BData As String
　　Dim ColO As Integer
'
　　BData = Cells(RowA, "G")
　　ColO = BData <> ""
　　Cells(RowA, "G") = "'" & BData & Left(",", -ColO) & RowB - 1
　　Cells(RowA, ColA).Interior.Color = vbYellow
　　Cells(RowA, ColB).Interior.Color = vbYellow
　　ColO = Cells(RowA, "AA").End(xlToLeft).Column
　　Cells(RowA, ColO + 1) = Cells(RowA, ColA)
　　Cells(RowA, ColO + 2) = Cells(RowA, ColB)
End Sub

図のAB列の最後、26、27が気になったのですが、旧プログラムを動かしてみても、これは出ませんでした。

お礼

前回、うれしくて確認不足でした。
22・30が１つになった事を確認しました。
26・27は前回、今回も最後に１つだけでてくるだけなのでよいです。
ありがとうございました。