删除列之间的重复对

我有两列数据，我需要比较并删除其他列中重复的单元格。 每列中可能有多个单元格是重复的，有些单元格可能是空白的，但我只关心在另一列中删除单元格对。

例如，运行以下程序：

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

这是另一种使用VBA的Collection对象来确定是否匹配的方法。 它应该比直接操作工作表的方法执行起来要快得多，但是如果你的数据库很广泛，而且执行速度太慢，那么也有一些方法可以加速这个过程。

源代码（原始数据）和结果在同一张工作表上的不同位置，但代码中应该明白如何更改（甚至可以将其更改为覆盖原始数据，如果需要的话）。

空白不包括在内。 如果你想包括，修改代码将是微不足道的

---

 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），并且可以有多个重复对（pair）。 以下例程将删除重复的数字：

 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 

另一种方法 – 一般

  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. 连接列A和B.

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

2. 匹配相同的数据。

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

3. 使用#N/A过滤列D