3 열 비교 및 ​​중복 삭제 vba

Question

이 경우 아래에서 복제본에 대해 한 열과 두 열을 비교하려고합니다. 아래의 이미지에서 D 열은 B 열과 F 열과 비교되며 D 열에서 중복 열을 삭제할 수 있기를 원합니다. 온라인에서 보았는데 어떻게 할 수 있는지 잘 모르겠습니다. 이것은 단순히 중간 열에서 데이터를 제거합니다 :

참고 검색 열은 열 D에 항상이며, 다른 두 사람은 B에 있고 F. 경우

Answer 1

이 중복 데이터를 삭제합니다 실제로 남은 간격을 채우지 않습니다.

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