Сравните два столбца, Очистить дубликаты ячеек

Question

Я пытаюсь сравнить две колонки (A и B) для дубликатов. В качестве вывода я пытаюсь получить ячейки, которые не совпадают (не дублируются). Значения столбца A взяты из таблицы 1, а значения столбца B - из таблицы 2. Цель кода - узнать, какие элементы были удалены из таблицы 2 (столбец B).

Данные выглядят следующим образом:

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

Вывод должен быть:

A           B
BMW
FIAT

Это работает для выделения дубликатов, но как получить удаленные значения, которые являются дубликатами? Например, используя .ClearContents. Затем после этого у меня есть l oop для удаления пустых строк в диапазоне.

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

Answer 1

Попробуйте:

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

Обратите внимание, что мы запускаем циклы снизу вверх .

Answer 2

вы можете использовать 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

или с 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

, что, если сохранение «верхов» наверху будет проблемой, становится:

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