如何快速刪除兩個excel工作表之間的重複項vba

Question

我使用的是vba，我有兩張工作表，一個名爲「Do Not Call」，在A列中有大約800,000行數據。我想用這些數據檢查第二列中的列I，名爲「Sheet1」。如果找到匹配項，我希望它刪除「Sheet1」中的整行。我已經量身定製了我從類似問題中找到的代碼：Excel formula to Cross reference 2 sheets, remove duplicates from one sheet並運行它，但沒有任何反應。我沒有得到任何錯誤，但它不起作用。

這是目前我試圖代碼，不知道爲什麼它不工作

Option Explicit 
Sub CleanDupes() 
Dim wsA As Worksheet 
Dim wsB As Worksheet 
Dim keyColA As String 

Dim keyColB As String 
Dim rngA As Range 
Dim rngB As Range 
Dim intRowCounterA As Integer 
Dim intRowCounterB As Integer 
Dim strValueA As String 


keyColA = "A" 
keyColB = "I" 

intRowCounterA = 1 
intRowCounterB = 1 

Set wsA = Worksheets("Do Not Call") 
Set wsB = Worksheets("Sheet1") 

Dim dict As Object 
Set dict = CreateObject("Scripting.Dictionary") 

Do While Not IsEmpty(wsA.Range(keyColA & intRowCounterA).Value) 
    Set rngA = wsA.Range(keyColA & intRowCounterA) 
    strValueA = rngA.Value 
    If Not dict.Exists(strValueA) Then 
     dict.Add strValueA, 1 
    End If 
    intRowCounterA = intRowCounterA + 1 
Loop 

intRowCounterB = 1 
Do While Not IsEmpty(wsB.Range(keyColB & intRowCounterB).Value) 
    Set rngB = wsB.Range(keyColB & intRowCounterB) 
    If dict.Exists(rngB.Value) Then 
     wsB.Rows(intRowCounterB).delete 
     intRowCounterB = intRowCounterB - 1 
    End If 
    intRowCounterB = intRowCounterB + 1 
Loop 
End Sub 

我道歉，如果上面的代碼是不是在一個代碼標記。這是我第一次在網上發佈代碼，我不知道我是否做得對。

Answer 1

我不好意思承認自己的共享代碼搞糊塗了......反正實踐我重寫使用數組，而不是通過表值循環是：

Option Explicit 
Sub CleanDupes() 
    Dim targetArray, searchArray 
    Dim targetRange As Range 
    Dim x As Long 

    'Update these 4 lines if your target and search ranges change 
    Dim TargetSheetName As String: TargetSheetName = "Sheet1" 
    Dim TargetSheetColumn As String: TargetSheetColumn = "I" 
    Dim SearchSheetName As String: SearchSheetName = "Do Not Call" 
    Dim SearchSheetColumn As String: SearchSheetColumn = "A" 

    'Load target array 
    With Sheets(TargetSheetName) 
     Set targetRange = .Range(.Range(TargetSheetColumn & "1"), _ 
       .Range(TargetSheetColumn & Rows.Count).End(xlUp)) 
     targetArray = targetRange 
    End With 
    'Load Search Array 
    With Sheets(SearchSheetName) 
     searchArray = .Range(.Range(SearchSheetColumn & "1"), _ 
       .Range(SearchSheetColumn & Rows.Count).End(xlUp)) 
    End With 


    Dim dict As Object 
    Set dict = CreateObject("Scripting.Dictionary") 
    'Populate dictionary from search array 
    If IsArray(searchArray) Then 
     For x = 1 To UBound(searchArray) 
      If Not dict.exists(searchArray(x, 1)) Then 
       dict.Add searchArray(x, 1), 1 
      End If 
     Next 
    Else 
     If Not dict.exists(searchArray) Then 
      dict.Add searchArray, 1 
     End If 
    End If 

    'Delete rows with values found in dictionary 
    If IsArray(targetArray) Then 
     'Step backwards to avoid deleting the wrong rows. 
     For x = UBound(targetArray) To 1 Step -1 
      If dict.exists(targetArray(x, 1)) Then 
       targetRange.Cells(x).EntireRow.Delete 
      End If 
     Next 
    Else 
     If dict.exists(targetArray) Then 
      targetRange.EntireRow.Delete 
     End If 
    End If 
End Sub 

編輯：因爲它困擾着我，我重讀了你提供的代碼。它讓我感到困惑，因爲它沒有按照我預期的方式編寫，除非你僅僅檢查字符串值，否則就會失敗。我添加的話來表明它在做什麼在這個片斷：後來

'Checks to see if the particular cell is empty. 
Do While Not IsEmpty(wsA.Range(keyColA & intRowCounterA).Value) 
    'Stores the cell to a range for no good reason. 
    Set rngA = wsA.Range(keyColA & intRowCounterA) 
    'Converts the value of the cell to a string because strValueA is a string. 
    strValueA = rngA.Value 
    'Checks to see if the string is in the dictionary. 
    If Not dict.Exists(strValueA) Then 
     'Adds the string to the dictionary. 
     dict.Add strValueA, 1 
    End If 

然後：

'checks the value, not the value converted to a string. 
If dict.Exists(rngB.Value) Then 

失敗的原因是腳本解釋不考慮雙等於一個字符串，即使他們如果double被轉換爲一個字符串，它將是相同的。

兩種方法來解決你發佈的代碼，或者改線我只是表明這個：

If dict.Exists(cstr(rngB.Value)) Then 

也可以更改Dim strValueA As String到Dim strValueA。

Answer 2

因爲我有時間，這裏是一個重寫放棄詞典，而是使用工作表函數。 （受Vlookup評論的啓發）。我不確定哪個會更快。

Sub CleanDupes() 
    Dim targetRange As Range, searchRange As Range 
    Dim targetArray 
    Dim x As Long 
    'Update these 4 lines if your target and search ranges change 
    Dim TargetSheetName As String: TargetSheetName = "Sheet1" 
    Dim TargetSheetColumn As String: TargetSheetColumn = "I" 
    Dim SearchSheetName As String: SearchSheetName = "Do Not Call" 
    Dim SearchSheetColumn As String: SearchSheetColumn = "A" 

    'Load target array 
    With Sheets(TargetSheetName) 
     Set targetRange = .Range(.Range(TargetSheetColumn & "1"), _ 
       .Range(TargetSheetColumn & Rows.Count).End(xlUp)) 
     targetArray = targetRange 
    End With 
    'Get Search Range 
    With Sheets(SearchSheetName) 
     Set searchRange = .Range(.Range(SearchSheetColumn & "1"), _ 
       .Range(SearchSheetColumn & Rows.Count).End(xlUp)) 
    End With 
    If IsArray(targetArray) Then 
     For x = UBound(targetArray) To 1 Step -1 
      If Application.WorksheetFunction.CountIf(searchRange, _ 
             targetArray(x, 1)) Then 
       targetRange.Cells(x).EntireRow.Delete 
      End If 
     Next 
    Else 
     If Application.WorksheetFunction.CountIf(searchRange, targetArray) Then 
      targetRange.EntireRow.Delete 
     End If 
    End If 
End Sub