3つの列の比較と重複の削除vba

Question

この場合、以下の例では、1つの列と2つの列を重複して比較したいと考えています。下の画像では、列Dが列Bと列Fの両方と比較され、そこから列Dから列を削除できるようにしたいと考えています。私はオンラインで調べました。

Answer 1

検索列が列Dに常にあり、2つの他のものは、BおよびF

注にある場合、これは、重複データを消去します。これは、単に中央の列内のデータを削除します実際には残っているギャップを埋めるわけではありません。

Sub deleteThreeColDupes() 

Dim sourceRange As range 
Dim colOne As range 
Dim colTwo As range 
Dim myCell As range 
Dim checkCell As range 

'Set the search ranges 
Set colOne = range("B2", Cells(Rows.count, 2).End(xlUp)) 
Set colTwo = range("F2", Cells(Rows.count, 6).End(xlUp)) 
Set sourceRange = range("D2", Cells(Rows.count, 4).End(xlUp)) 

'Compare with the first column. If there is a match, clear the value and exit the loop. 
'if no match in first column, compare with the second column. 
For Each myCell In sourceRange 
    For Each checkCell In colOne 
     If myCell.Value = checkCell.Value Then 
      myCell.Value = "" 
      Exit For 
     End If 
    Next checkCell 
    If myCell.Value <> "" Then 
     For Each checkCell In colTwo 
      If myCell.Value = checkCell.Value Then 
       myCell.Value = "" 
       Exit For 
      End If 
     Next checkCell 
    End If 
Next myCell 

'Clear sets 
Set colOne = Nothing 
Set colTwo = Nothing 
Set sourceRange = Nothing 

End Sub 

Answer 2

コレクションを使用すると、より効率的なバージョンです。列BとFを1回だけ反復し、反復せずに結果のコレクション内で値を即座に検索することができます。

Sub deleteDups() 

    ' setup column ranges 
    Dim rngB As Range 
    Dim rngD As Range 
    Dim rngF As Range 

    With ActiveSheet 
     Set rngB = .Range(.[b2], .[b2].End(xlDown)) 
     Set rngD = .Range(.[d2], .[d2].End(xlDown)) 
     Set rngF = .Range(.[f2], .[f2].End(xlDown)) 
    End With 

    ' store columns B and F in collections with value = key 
    Dim colB As New Collection 
    Dim colF As New Collection 

    Dim c As Range 
    For Each c In rngB: colB.Add c, c: Next 
    For Each c In rngF: colF.Add c, c: Next 

    ' quickly check if the value in any of the columns 
    For Each c In rngD 
     If contains(colB, CStr(c)) Or contains(colF, CStr(c)) Then 
      Debug.Print "Duplicate """ & c & """ at address " & c.Address 
      ' c.Clear ' clears the duplicate cell 
     End If 
    Next 

End Sub 

Function contains(col As Collection, key As String) As Boolean 
    On Error Resume Next 
    col.Item key 
    contains = (Err.Number = 0) 
    On Error GoTo 0 
End Function 

出力：

Duplicate "cry" at address $D$4 
Duplicate "car" at address $D$5 
Duplicate "cat" at address $D$6