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 - suggest you save the w/book before running!

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

Dim objStopWords As Object
Dim rCur 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)
    For Each rCur In Intersect(.UsedRange, .Columns("A:H"))
        sCurWord = LCase$(Trim$(CStr(rCur.Value)))
        If sCurWord <> "" Then
            If objStopWords.exists(sCurWord) Then rCur.ClearContents
        End If
    Next rCur
End With

objStopWords.RemoveAll
Set objStopWords = Nothing

End Sub

 

[adwordsguy]

Thanks Alan! That seems to work perfectly.

Just a question, if the rows or columns changed in either sheet is there anything that needs to be modified in the Macro? If so can you point out where that is and what I would need to change? What would likely change in the future is an increase, more rows for both sheets and possibly more columns in Sheet1.

Thanks again, can hardly believe I got an answer let alone one that worked right out of the gate.

 

[al_b_cnu]

Hi Steve,

The code automatically caters for an increase in rows, this statement tells the code it's columns A to H:

For Each rCur In Intersect(.UsedRange, .Columns("A:H"))

 

[adwordsguy]

Amazing! Just so I'm clear if I wanted to extend it to column ZZ the code would look like this:

For Each rCur In Intersect(.UsedRange, .Columns("A:ZZ"))

Is that correct?

 

[al_b_cnu]

Yep

 

[al_b_cnu]

... and if you wanted it to look in the entire sheet just use

For Each rCur In .UsedRange

(untested)

 

[adwordsguy]

Thanks so much Alan, you have saved me an incredible amount of time. Hope you win the lottery!

Cheers,
Steve

 

[al_b_cnu]

Well I havent tonight

Maybe next Friday ...

 

[adwordsguy]

Hi Alan,

I've been using the script you sent me and it's been very helpful, I really appreciate your help with it.

I ran into an issue today where this same function would be helpful with a slight modification. I was wondering if it would be easy to modify the script so that instead of deleting the word it coloured the cell the word was contained in (or the coloured the text). The goal is to find a way to sort out the rows that contain a stop word without loosing the stop word.

Would you mind taking a look and letting me know when you get a minute?

Let me know if you have any questions.

Best regards,
Steve