比较两个不同工作表中的两个单元格并删除任何重复项

Question

I am having a few problems with some Macro code I have adapted from some code I found online and wondered if anyone would be able to help.

Essentially, I want the Macro to run and compare two cells in the 'Working List' worksheet to the entries in the 'Import Here' worksheet and delete any duplicates.

When I run the code, it seems to work on the title cell but then doesn't seem to work.

Any help would be greatly appreciated.

Here is the code below: I have tried to annotate it for my own understanding too.

Sub Comparison_Macro()
Dim iListCount As Integer
Dim iCtr As Integer

' Turn off screen updating to speed up macro.
 Application.ScreenUpdating = False

' Get count of records to search through (list that will be deleted).
iListCount = Sheets("Import Here").Range("A1:A1000").Rows.Count

' Loop through the "master" list.
For Each x In Sheets("Working List").Range("A1:A30")
   ' Loop through all records in the second list.
   For iCtr = 1 To iListCount
  ' Do comparison of Column A in next record.
  If x.Value = Sheets("Import Here").Cells(iCtr, 1).Value Then
        'Do comparison of Column B in next record.
        If Sheets("Working List").Cells(iCtr, 2) = Sheets("Import Here").Cells(iCtr, 2).Value Then
            ' If match is true for Columns A and B then delete row.
            Sheets("Import Here").Cells(iCtr, 1).EntireRow.Delete xlShiftUp
        End If
    ' Increment counter to account for deleted row.
    iCtr = iCtr + 1
  End If
 Next iCtr
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub

Answer 1

Here's a version that uses countifs to check if columns A and B on "Import Here" exist on the "Working List" sheet. As it is deleting rows from the "Import Here" sheet the code loops through every row and deletes if it's found on the "Working List" sheet.

My comment was not entirely correct as I hadn't seen that you were looping through every row on one sheet for each row on the other so it maybe wasn't getting out of sync. That said I still think that using countifs is a better way to do this.

Sub Comparison_Macro()
    Dim iListCount As Integer
    Dim iCtr As Integer

    ' Turn off screen updating to speed up macro.
     Application.ScreenUpdating = False

    ' Get count of records to search through (list that will be deleted).
    iListCount = Sheets("Import Here").Range("A1:A1000").Rows.Count

    ' Loop through the "master" list.
    For iCtr = 1 To iListCount
       ' Loop through all records in the second list.

      ' Do comparison of Column A and B in next record.

        If Application.WorksheetFunction.CountIfs(Range("'Working List'!A1:A1000"), Range("A" & iCtr), Range("'Working List'!B1:B1000"), Range("B" & iCtr)) > 0 Then
          Sheets("Import Here").Cells(iCtr, 1).EntireRow.Delete xlShiftUp
          iCtr = iCtr - 1
        End If

    Next iCtr
    Application.ScreenUpdating = True
    MsgBox "Done!"
End Sub

Answer 2

you coudl consider an Autofilter() approach:

Sub Comparison_Macro()
    Dim workingRng  As Range, importRng As Range, deleteRng As Range, cell As Range

    With Worksheets("Working List") '<--| reference "Working List" sheet
        Set workingRng = .Range("A1", .cells(.Rows.Count, 1).End(xlUp)) '<--| set the "Working List" sheet column A values from row 1 down to last not empty row to be checked in "Import Here" sheet
    End With

    With Sheets("Import Here") '<--| reference "Import Here" sheet
        With .Range("A1", .cells(.Rows.Count, 1).End(xlUp)) '<--| reference its column A range from row 1 down to last not empty row
            .AutoFilter Field:=1, Criteria1:=Application.Transpose(workingRng.Value), Operator:=xlFilterValues '<--| filter referenced cells with 'workingRng' values
            Set importRng = .SpecialCells(xlCellTypeVisible) '<--| set filtered cells to 'importRng' range
            Set deleteRng = .Offset(, 1).Resize(1, 1) '<--| initialize 'deleteRng' to a "dummy" cell that's out of range of interest: it'll be used to avoid subsequent checking against "nothing" before calling 'Union()' method and eventually discharged
        End With
        .AutoFilterMode = False
    End With

    For Each cell In importRng '<--| loop through filtered cells in "Import Here"
        If workingRng.Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole).Offset(, 1) = cell.Offset(, 1) Then Set deleteRng = Union(deleteRng, cell) '<--| if current cell adjacent value matches corresponding value in "working range" then update 'deletRng'
    Next
    Set deleteRng = Intersect(importRng, deleteRng) '<--| get rid of "dummy" cell
    If Not deleteRng Is Nothing Then deleteRng.EntireRow.Delete '<--| if any survived cell in "Import Here" then delete corresponding rows
End Sub