Compare two columns in Excel and delete from the second what was matched in the first

Question

I have two columns of values, "A" that contains words only, one word per cell, and Column "B" that contains urls, one url per cell.

The following code does compare between both columns and only deletes the exact corresponding value, i.e. "A" has "erotic.com" value in one cell, and "B" has "erotic.com" in another cell (then value in "B" is deleted as it matches the value of "A")

Could this code be modified to compare between "A" and "B" and delete the value of "B" if any of the words in "A" matches? e.g. "A" has the word "erotic" in one cell, and "B" has the url "erotic.com" in another cell (value in "B" should be deleted as "erotic" is found in "A")?

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

tigeravatar tigeravatar · Accepted Answer · 2013-08-23T17:48:17

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

Compare two columns in Excel and delete from the second what was matched in the first

1 Answers