Question

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

例如，运行以下程序：

this

需要导致：

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

有没有办法在不使用中间条件格式的情况下执行此操作？

Answer 1

查看以下代码是否有任何帮助。

答案：假设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 2

实际上，这段代码是对Vasant Kumbhojkar代码的修改。

我发布它是新的，因为我不想编辑他的答案。

因此，每个初学者都可以看到代码不同且有效地使用循环。

您可以尝试如下：

    Imports SHDocVw
Imports mshtml
Imports System.Net

 Module Module1
 Dim HTMLDoc As HTMLDocument
 Dim MyBrowser As InternetExplorer
 Sub Main()
 MyGmail()
 End Sub
Sub MyGmail()

Dim MyHTML_Element As IHTMLElement
Dim MyURL As String
On Error GoTo Err_Clear
MyURL = "https://example.com/"
 MyBrowser = New InternetExplorer
MyBrowser.Silent = True
MyBrowser.Navigate(MyURL)
MyBrowser.Visible = True
 Do
Loop Until MyBrowser.ReadyState = tagREADYSTATE.READYSTATE_COMPLETE
HTMLDoc = MyBrowser.Document
HTMLDoc.all.txtUserID.Value = "xyz@example.com" 'Enter your email id here
HTMLDoc.all.txtPassword.Value = "test123" 'Enter your password here

For Each MyHTML_Element In HTMLDoc.getElementsByTagName("input")
If MyHTML_Element.Type = "submit" Then MyHTML_Element.click() : Exit For
Next

 'Navigate to reports folder
 Dim newReportURL As String
 newReportURL = "https://some_static_url_to_navigate"
MyBrowser.Navigate(newReportURL)
Dim i As Integer
 Dim reportURL As String
 reportURL = ""
i = 0
  For Each MyHTML_Element In HTMLDoc.getElementsByTagName("a")
If DirectCast(MyHTML_Element, mshtml.IHTMLAnchorElement).innerText = "Export" And i = 1 Then

    reportURL = DirectCast(MyHTML_Element, mshtml.IHTMLAnchorElement).href
   End If

  If DirectCast(MyHTML_Element, mshtml.IHTMLAnchorElement).innerText = "Export" Then
    i = i + 1
End If


 Next

  MyBrowser.Navigate(reportURL)

For Each MyHTML_Element In HTMLDoc.getElementsByTagName("input")
If MyHTML_Element.Type = "submit" Then
    MyHTML_Element.click() : Exit For
End If

Next


Dim xlsReportURL As String
xlsReportURL = DirectCast(MyBrowser.Document, mshtml.IHTMLDocument).url

'Not working it gets the page HTML
MyBrowser.ExecWB(OLECMDID.OLECMDID_SAVEAS,      OLECMDEXECOPT.OLECMDEXECOPT_DONTPROMPTUSER, savePath, vbNull)

Err_Clear:
If Err.Number <> 0 Then
Err.Clear()
Resume Next
End If
End Sub
End Module

Answer 3

如果您的目标是：

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

enter image description here

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

enter image description here

连接A列和B列。

C2=CONCATENATE(B2,"|",A2)
匹配相同的数据。

D2=MATCH(A2&"|"&B2,C:C,0)
使用#N/A

Answer 4

这是另一种使用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

这是一个产生的例子：

enter image description here

删除列之间的重复对

4 个答案: