比較3列和刪除重複vba

Question

在這種情況下，我想比較一列與兩列重複。在下面的圖像列D與列B和F進行比較，從那裏我希望能夠刪除列D中的重複。我在網上查找，我不知道我怎麼能做到這一點。

Answer 1

這將清除重複數據如果搜索欄始終在列d和兩個其他的都是在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進行一次迭代，並且可以在迭代結果集合中立即查找值。

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