Vergleichen von 3 Spalten und Löschen von Duplikaten vba

Question

In diesem Fall möchte ich eine Spalte mit zwei Spalten für Duplikate vergleichen. Im Bild unten wird Spalte D mit beiden Spalten B und F verglichen und von dort möchte ich in der Lage sein, die Duplikate aus Spalte D zu löschen. Ich habe online gesucht und bin mir nicht sicher, wie ich das machen kann.

Answer 1

Dies wird doppelte Daten löschen, wenn die Suchspalte immer in Spalte D ist und die beiden anderen sind in B und F.

Hinweis: Dies wird einfach die Daten in der mittleren Spalte entfernen , füllen Sie nicht wirklich die Lücken, die gelassen werden.

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

Eine etwas effizientere Version mit Sammlungen. Es durchläuft die Spalten B und F nur einmal und Werte können sofort in den resultierenden Sammlungen ohne Iteration gesucht werden.

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 

Ausgang:

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