CODEWITHSUNDEEP
excelvba
10101
10101

Reputation: 2402

Compare two columns, Clear duplicate cells

I am trying to compare two columns (A and B) for duplicates. As an output I am trying to get cells that does not match (not duplicates). Column A values are coming from table 1 and Column B values are coming from table 2. Code target is basically to get to know which items were deleted from table 2 (Column B).

Data looks like:

A           B
BMW         PORSCHE
FIAT        VOLVO
VOLVO       AUDI
PORSCHE     FERRARI
FERRARI     TOYOTA
TOYOTA
AUDI

Output should be:

A           B
BMW
FIAT

This is working for highlighting duplicates, but how to get values deleted that are duplicates? For example using .ClearContents. Then after that I have loop for deleting empty rows in range. 

Sub MarkDuplicatesInCompare()

    Dim ws As Worksheet
    Dim cell As Range
    Dim myrng As Range
    Dim clr As Long
    Dim lastCell As Range
    Dim EntireRow As Range

    Set ws = ThisWorkbook.Sheets("Compare")
    Set myrng = ws.Range(ws.Cells(2, 1), ws.Cells(ws.Rows.Count, "B").End(xlUp))
    With myrng
        Set lastCell = .Cells(.Cells.Count)
    End With

    myrng.Interior.ColorIndex = xlNone

    clr = 3

    For Each cell In myrng
        If Application.WorksheetFunction.CountIf(myrng, cell) > 1 Then

            If myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Address = cell.Address Then

                cell.Interior.ColorIndex = clr
                clr = clr
            Else

                cell.Interior.ColorIndex = myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Interior.ColorIndex
            End If
        End If
    Next

    ' Delete empty rows

    For I = myrng.Rows.Count To 1 Step -1
        Set EntireRow = myrng.Cells(I, 1).EntireRow
        If Application.WorksheetFunction.CountA(EntireRow) = 0 Then
            EntireRow.Delete
        End If
    Next

End Sub

Upvotes: 0

Views: 85

Answers (2)

HTH
HTH

Reputation: 2031

you could use AutoFilter()

With Range("A1", Cells(Rows.Count, 1).End(xlUp))
    .Rows(1).EntireRow.Insert ' insert temporary row for dummy headers
    With .Offset(-1).Resize(.Rows.Count + 1)
        .Range("A1:B1").Value = Array("h1", "h2") ' write dummy headers
        .AutoFilter field:=1, Criteria1:=Application.Transpose(Range("B1", Cells(Rows.Count, 2).End(xlUp)).Value), Operator:=xlFilterValues
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).ClearContents
        .Parent.AutoFilterMode = False
        .Rows(1).EntireRow.Delete ' remove dummy headers temporary row
    End With
End With
Range("B1", Cells(Rows.Count, 2).End(xlUp)).ClearContents ' clear column B values

or with Find()

Dim cel As Range
With Range("B1", Cells(Rows.Count, 2).End(xlUp))
    For Each cel In Range("A1", Cells(Rows.Count, 1).End(xlUp))
        If Not .Find(what:=cel.Value, LookIn:=xlValues, lookat:=xlWhole) Is Nothing Then cel.ClearContents
    Next
    .ClearContents
End With

which, should keeping "surivors" at the top be an issue, becomes:

Dim cel As Range, s As String
With Range("B1", Cells(Rows.Count, 2).End(xlUp))
    For Each cel In Range("A1", Cells(Rows.Count, 1).End(xlUp))
        If Not .Find(what:=cel.Value, LookIn:=xlValues, lookat:=xlWhole) Is Nothing Then s = s & cel.Address(False, False) & " "
    Next
    .ClearContents
End With
If s <> vbNullString Then Range(Replace(Trim(s), " ", ",")).Delete xlUp

Upvotes: 1

Gary&#39;s Student
Gary&#39;s Student

Reputation: 96753

Give this a try:

Sub Keanup()
    Dim i As Long, j As Long, Na As Long, Nb As Long
    Na = Cells(Rows.Count, "A").End(xlUp).Row
    Nb = Cells(Rows.Count, "B").End(xlUp).Row

    For i = Na To 1 Step -1
        v = Cells(i, "A").Value
        For j = Nb To 1 Step -1
            If v = Cells(j, "B").Value Then
                Cells(i, "A").Delete shift:=xlUp
                Cells(j, "B").Delete shift:=xlUp
                Exit For
            End If
        Next j
    Next i
End Sub

Note we run the loops bottom up.

Upvotes: 2

Related Questions