[英]Compare two cells in two different worksheets and delete any duplicates
我從網上找到的一些代碼改編而成的某些宏代碼遇到一些問題,想知道是否有人可以提供幫助。
本質上,我希望宏運行並將“工作列表”工作表中的兩個單元格與“此處輸入”工作表中的條目進行比較,並刪除所有重復項。
當我運行代碼時,它似乎可以在標題單元格上工作,但隨后似乎不起作用。
任何幫助將不勝感激。
這是下面的代碼:為了我自己的理解,我也嘗試對其進行注釋。
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
這是一個使用Countifs的版本來檢查“工作清單”表上是否存在“在此處導入”上的列A和列B。 當它從“在此處導入”工作表中刪除行時,代碼循環遍歷每一行,並刪除在“工作列表”工作表中找到的行。
我的評論並不完全正確,因為我沒有看到您在一張紙上的每一行之間循環瀏覽另一行上的每一行,因此它可能並沒有保持同步。 話雖如此,我仍然認為使用Countifs是一種更好的方法。
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
您可以考慮使用Autofilter()
方法:
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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.