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
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
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.