Macro for Find & Replace Multiple Words, Exact Match

[adwordsguy]

Hi there,

This is the first time posting at MrExcel.com but not the first time using it. Thanks to everyone who's contributed, you've helped me quite a bit over the last year or so.

I'm a basic Excel user (no pivot table experience or writing macro's) however I have a problem where I think a Macro would be the best solution. I've spent the last few hours trying to find a macro like the one I'm imagining that would work for my needs but haven't had any luck so I'm hoping someone here may be able to help.

The Situation:
I have an excel document with 2 worksheets. Sheet1 is named 'groups' and has several columns (A-H) with one word in each cell this goes on for approximately 1000 rows.

Sheet2 is named 'stopwords' and contains one column (A) with one word in each cell continuing down to about row 600.

The Problem:
In Sheet1 I need to clear a cell that contains a word found in Sheet 2 but only if that word in Sheet1 matches exactly to the words found in Sheet2.

I hope I've explained that clearly enough, please let me know if you have any questions.

Thanks,
Steve

 

[al_b_cnu]

Hi Steve,

Try this macro:

Option Explicit

Sub HighlightCells()
Const sGroupsSheetName As String = "Groups"
Const sStopWordsSheetName As String = "StopWords"

Dim objStopWords As Object
Dim rCur As Range
Dim rCheckRange As Range
Dim sCurWord As String

Dim wsGroups As Worksheet
Dim wsStopwords As Worksheet

Set objStopWords = Nothing
Set objStopWords = CreateObject("Scripting.Dictionary")

With Sheets(sStopWordsSheetName)
    For Each rCur In Intersect(.Columns("A"), .UsedRange)
        sCurWord = LCase$(Trim$(CStr(rCur.Value)))
        If sCurWord <> "" Then
            On Error Resume Next
            objStopWords.Add Key:=sCurWord, Item:=1
            On Error GoTo 0
        End If
    Next rCur
End With

With Sheets(sGroupsSheetName)
    Set rCheckRange = Intersect(.UsedRange, .Columns("A:ZZ"))
    rCheckRange.Interior.ColorIndex = xlNone
    For Each rCur In rCheckRange
        sCurWord = LCase$(Trim$(CStr(rCur.Value)))
        If sCurWord <> "" Then
            If objStopWords.exists(sCurWord) Then
                With rCur.Interior
                    .ColorIndex = 6
                    .Pattern = xlSolid
                End With
            End If
        End If
    Next rCur
End With

objStopWords.RemoveAll
Set objStopWords = Nothing

End Sub