Удаление пар дубликатов между столбцами

Question

У меня есть два столбца данных, которые мне нужны для сравнения и удаления ячеек, которые дублируются в другом столбце. Внутри каждого столбца может быть несколько ячеек, и некоторые ячейки могут быть пустыми, но я только забочусь об удалении ячеек с парой в другом столбце.

Например, выполнив процедуру:

Column A | Column B 
    0.1  | 3.2 
    0.5  | 0.1 
    3.2  | 0.1 
    1.4  | 

потребностей привести к:

Column A | Column B 
    0.5  | 0.1 
    1.4  | 

Есть ли способ сделать это без использования посредника условного форматирования?

Answer 1

Вот другой подход, использующий объект Collection VBA, чтобы определить, есть ли совпадение. Он должен выполняться гораздо быстрее, чем методы, которые непосредственно манипулируют листом, но если ваша база данных обширна и выполнение все еще слишком медленное, есть некоторые способы ускорить это.

Источник (исходные данные) и результаты находятся в разных местах на одном листе, но в коде должно быть очевидно, как изменить это (или даже изменить его, чтобы перезаписать исходные данные, если вы этого хотите.

Пробелы не включены Если вы хотите включить, изменения в коде будет тривиальным

---

Option Explicit 
Sub DeleteDuplicateColumnPairs() 
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range 
    Dim vSrc As Variant, vRes() As Variant 
    Dim colFirst As Collection, colSecond As Collection 
    Dim I As Long, J As Long, V As Variant 
    Dim LastRow As Long 

'Set Source and Results worksheets and result range 
Set wsSrc = Worksheets("sheet3") 
Set wsRes = Worksheets("sheet3") 
    Set rRes = wsRes.Range("D1") 

'Get source data 
With wsSrc 
    LastRow = .Range("a1", .Cells(.Rows.Count, "B")).Find(what:="*", after:=[A1], LookIn:=xlValues, _ 
       searchorder:=xlByRows, searchdirection:=xlPrevious).Row 
    vSrc = .Range("a1", .Cells(LastRow, "B")) 
End With 

'Collect first column data 
'skip header row 
Set colFirst = New Collection 
On Error Resume Next 
For I = 2 To UBound(vSrc, 1) 
    If Len(vSrc(I, 1)) > 0 Then 
    colFirst.Add Item:=vSrc(I, 1), Key:=CStr(vSrc(I, 1)) 
    Select Case Err.Number 
     Case 457 
      colFirst.Add Item:=vSrc(I, 1) 
      Err.Clear 
     Case Is <> 0 
      Debug.Print Err.Number, Err.Description, Err.Source 
      Stop 'for debugging. 
    End Select 
    End If 
Next I 
On Error GoTo 0 

'collect second column data 
'if present in first column, then remove from both 
' but will then need to see if there is a duplicate in first column 
' and re-enter it with the key 

Set colSecond = New Collection 
On Error Resume Next 
For I = 2 To UBound(vSrc) 
    If Len(vSrc(I, 2)) > 0 Then 
    V = colFirst(CStr(vSrc(I, 2))) 
    Select Case Err.Number 
     Case 5 
      colSecond.Add vSrc(I, 2) 
      Err.Clear 
     Case 0 
      colFirst.Remove (CStr(vSrc(I, 2))) 
      'is there another dup in colFirst? 
      For J = 1 To colFirst.Count 
       If colFirst(J) = vSrc(I, 2) Then 
        colFirst.Remove J 
        colFirst.Add vSrc(I, 2), CStr(vSrc(I, 2)) 
        Exit For 
       End If 
      Next J 
     Case Else 
      Debug.Print Err.Number, Err.Description, Err.Source 
      Stop 
    End Select 
    End If 
Next I 
On Error GoTo 0 

'Construct Results Array 
ReDim vRes(0 To IIf(colFirst.Count > colSecond.Count, colFirst.Count, colSecond.Count), 1 To 2) 

'Populate headers 
vRes(0, 1) = vSrc(1, 1) 
vRes(0, 2) = vSrc(1, 2) 

'Populate the data 
For I = 1 To colFirst.Count 
    vRes(I, 1) = colFirst(I) 
Next I 

For I = 1 To colSecond.Count 
    vRes(I, 2) = colSecond(I) 
Next I 

'Write data to worksheet 
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2)) 
With rRes 
    .EntireColumn.Clear 
    .Value = vRes 
    .HorizontalAlignment = xlRight 
    With .Rows(1) 
     .Font.Bold = True 
     .HorizontalAlignment = xlCenter 
    End With 
    .EntireColumn.AutoFit 
End With 

End Sub 

---

Вот пример того, что это дает:.

Answer 2

Проверьте, подходит ли следующий код.

Предположим, что в столбце A и столбце B есть несколько чисел (например, 10), и может быть много дубликатов (пар). Следующая программа будет удалить дубликаты номеров:

Private Sub CommandButton1_Click() 
For i = 1 To 10 
For j = 1 To 10 
    If Cells(i, 1) = Cells(j, 2) Then 
     Cells(i, 1).ClearContents 
     Cells(j, 2).ClearContents 
     Exit For 
    End If 
Next 
Next 

''''''''The next lines remove blank cells from columns A and B 
Do 
For i = 1 To 10 
If Cells(i, 1) = "" Then 
    Cells(i, 1).Delete Shift:=xlUp 
End If 
Next 
Loop While Cells(1, 1) = "" 

Do 
For i = 1 To 10 
If Cells(i, 2) = "" Then 
    Cells(i, 2).Delete Shift:=xlUp 
End If 
Next 
Loop While Cells(1, 2) = "" 
End Sub 

Вы можете объединить две петли и изменять код в соответствии с вашими потребностями.

Answer 3

Собственно, этот код является модификацией кода Vasant Kumbhojkar.

Я разместил его как новый, потому что я не хочу редактировать его ответ.

Итак, каждый новичок может видеть код, отличающийся и эффективный цикл использования.

Вы можете попробовать следующим образом:

Dim row, aRow, bRow, total As Integer 

'Clear duplicate cell 
For aRow = 1 To 10 Step 1 

    For bRow = 1 To 10 Step 1 

     If Cells(aRow, 1) = Cells(bRow, 2) Then 

      Cells(aRow, 1).ClearContents 

      Cells(bRow, 2).ClearContents 

      Exit For 

     End If 

    Next bRow 

Next aRow 

'Clear blank cell from column A 
row = 1 
total = 10 

Do While row <= total 

    If Cells(row, 1) = "" Then 
     Cells(row, 1).Delete Shift:=xlUp 
     total = total - 1 
    Else 
     row = row + 1 
    End If 

Loop 

'Clear blank cell from column B 
row = 1 
total = 10 

Do While row <= total 

    If Cells(row, 2) = "" Then 
     Cells(row, 2).Delete Shift:=xlUp 
     total = total - 1 
    Else 
     row = row + 1 
    End If 

Loop 

Answer 4

Если ваша цель заключается в следующем:

Column1 Column2 Column3 
    0.1  3.2  delete 
    0.5  0.1  
    3.2  0.1  delete 
    1.4    
    100  200  delete 
    200  100  delete 
    300  400  delete 
    300  500  
    400  300  delete 

VBA Код:

Sub FindPairs() 

Dim i As Long, lastRow As Long 
Dim search As Range, result As Range, pair_right As Range 
Dim firstAddress As String 

lastRow = Range("A" & Cells.Rows.Count).End(xlUp).Row 

For i = 2 To lastRow 
    Set search = Cells(i, 1) 
    Set pair_right = Range(search.Address).Offset(0, 1) 

    If search <> "" Then 
     With Worksheets("sheet2").Columns(2) 
      Set result = .find(what:=search, lookat:=xlWhole) 
      If Not result Is Nothing Then 
       firstAddress = result.Address 
       If Range(firstAddress).Offset(0, -1) = pair_right Then 
        pair_right.Offset(0, 1) = "delete" 'mark row for delete 
       Else 
        Do 
         Set result = .FindNext(result) 
         If Not result Is Nothing _ 
         And result.Address <> firstAddress _ 
         And Range(result.Address).Offset(0, -1) = pair_right _ 
         Then 
          pair_right.Offset(0, 1) = "delete" 
         End If 
        Loop While Not result Is Nothing And result.Address <> firstAddress 
       End If 
      End If 
     End With 
    End If 
Next i 

' how to delete marked rows? 
' if your have large row then clear contents will better 
' after clear contents then sort 

End Sub 

Если вы действительно хотите использовать VBA удалить попробовать это:

Sub DeleteRow() 
For i = Range("A" & Cells.Rows.Count).End(xlUp).Row To 2 Step -1 
    If Cells(i, 3) = "delete" Then 
     Cells(i, 3).EntireRow.Delete 
    End If 
Next i 
End Sub 

Другой метод - Fomular

Column1 Column2 Connect2-1 Match 
    0.1  3.2 3.2|0.1  4 
    0.5  0.1 0.1|0.5  #N/A 
    3.2  0.1 0.1|3.2  2 
    1.4    |1.4   #N/A 
    100  200 200|100  7 
    200  100 100|200  6 
    300  400 400|300  10 
    300  500 500|300  #N/A 
    400  300 300|400  8 

1. Concatenate колонка А и В.

   C2=CONCATENATE(B2,"|",A2)

2. Совместить те же данные.

   D2=MATCH(A2&"|"&B2,C:C,0)

3. фильтр Колонка D с #N/A