Сравнение 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