在Excel中比較兩列並從第二個刪除第一個匹配的內容

Question

我有兩列值，「A」僅包含單詞，每個單元格一個單詞，列「B」包含url，一個url每個單元格。

以下代碼在兩列之間進行比較，只刪除確切的相應值，即「A」在一個單元中具有「erotic.com」值，而「B」在另一個單元中具有「erotic.com」 「B」中的值被刪除，因爲它與「A」的值相匹配）

可以修改此代碼以比較「A」和「B」，並刪除「B」的值「A」匹配？例如「A」在一個單元格中有「色情」一詞，而「B」在另一個單元格中有「erotic.com」網址（在「A」中發現「B」的值應該被刪除爲「色情」）？

Option Explicit 
Function RangeFound(SearchRange As Range, _ 
Optional ByVal FindWhat As String = "*", _ 
Optional StartingAfter As Range, _ 
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _ 
Optional LookAtWholeOrPart As XlLookAt = xlPart, _ 
Optional SearchRowCol As XlSearchOrder = xlByRows, _ 
Optional SearchUpDn As XlSearchDirection = xlPrevious, _ 
Optional bMatchCase As Boolean = False) As Range 

If StartingAfter Is Nothing Then 
    Set StartingAfter = SearchRange(1) 
End If 

Set RangeFound = SearchRange.Find(What:=FindWhat, _ 
After:=StartingAfter, _ 
LookIn:=LookAtTextOrFormula, _ 
LookAt:=LookAtWholeOrPart, _ 
SearchOrder:=SearchRowCol, _ 
SearchDirection:=SearchUpDn, _ 
MatchCase:=bMatchCase) 
End Function 
Sub ComparePermittedURLS() 
Dim rngLastCell As Range 
Dim rngColA As Range 
Dim rngColB As Range 
Dim n As Long, j As Long 
Dim DIC As Object ' Scripting.Dictionary 
Dim aryColB As Variant 
Dim aryColA As Variant 
Dim aryOutput As Variant 
Dim startTime 
Dim EndTime 
startTime = Timer 
'On Error GoTo ResetSpeed 
'SpeedOn 
Application.ScreenUpdating = False 
With Sheets("permitted_urls") '<--Using worksheet's CodeName, or, using tab name-- >ThisWorkbook.Worksheets ("Sheet1") 
    '// Find the last cell in each column, setting a reference to each column's range// 
    '// that contains data.               // 
    Set rngLastCell = RangeFound(.Columns(1), , .Cells(1, 1)) 
    If Not rngLastCell Is Nothing Then Set rngColA = .Range(.Cells(1), rngLastCell) 
    Set rngLastCell = RangeFound(.Columns(2), , .Cells(1, 2)) 
    If Not rngLastCell Is Nothing Then Set rngColB = .Range(.Cells(1, 2), rngLastCell) 

    '// In case either column was empty, provide a bailout point.     // 
    If rngColA Is Nothing Or rngColB Is Nothing Then 
     MsgBox "No data" 
     Exit Sub 
    End If 

    Set DIC = CreateObject("Scripting.Dictionary") 
    aryColA = rngColA.Value 
    '// fill the keys with unique values from Column A // 
    For n = 1 To UBound(aryColA, 1) 
     DIC.Item(CStr(aryColA(n, 1))) = Empty 
    Next 

    aryColB = rngColB.Value 
    '// Size an output array to the current size of data in Column B, so we can just// 
    '// overwrite the present values.            // 
    ReDim aryOutput(1 To UBound(aryColB, 1), 1 To 1) 

    '// Loop through the current values, adding just the values we don't find in // 
    '// the dictionary to out output array.           // 
    For n = 1 To UBound(aryColB) 
     If Not DIC.Exists(CStr(aryColB(n, 1))) Then 
      j = j + 1 
      aryOutput(j, 1) = aryColB(n, 1) 
     End If 
    Next 

    '// Kaplunk. // 
    rngColB.Value = aryOutput 

    Set DIC = Nothing 
    Erase aryColA 
    Erase aryColB 
    Erase aryOutput 
End With 
'ResetSpeed: 
'SpeedOff 
Application.ScreenUpdating = True 
EndTime = Timer 
MsgBox "Total Time: " & EndTime - startTime 

End Sub 

Answer 1

Sub ComparePermittedURLS() 

    Dim rngDel As Range 
    Dim rngFound As Range 
    Dim varWord As Variant 
    Dim strFirst As String 

    With Sheets("permitted_urls") 
     For Each varWord In Application.Transpose(.Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Value) 
      If Len(varWord) > 0 Then 
       Set rngFound = .Columns("B").Find(varWord, .Cells(.Rows.Count, "B"), xlValues, xlPart) 
       If Not rngFound Is Nothing Then 
        strFirst = rngFound.Address 
        Do 
         If Not rngDel Is Nothing Then Set rngDel = Union(rngDel, rngFound) Else Set rngDel = rngFound 
         Set rngFound = .Columns("B").Find(varWord, rngFound, xlValues, xlPart) 
        Loop While rngFound.Address <> strFirst 
       End If 
      End If 
     Next varWord 
    End With 

    If Not rngDel Is Nothing Then rngDel.Delete 

    Set rngDel = Nothing 
    Set rngFound = Nothing 

End Sub