VBA: Find and Replace Exact Match Words

[delonte]

After extensive research I finally found a VBS code to find and replace words in paragraphs only if its an exact match. The only problem I have is that the code only replaces a certain word only once in a specific cell.

So columns A through C have a bunch of paragraphs of text. Using this macro, it automatically scans all the words in column D and if it finds those words anywhere in columns A through C, it will replace it with the word next to it on column E. So if the sentence is "Hello how is hell hell?" in column A. And in column D there is a word hell - then the code below doesn't replace "hello" at all (working as intended), it does replace the first "hell" in the sentence (working as intended), but does not replace the second "hell" (not working as intended).

Anyone have any idea how to tweak the code so all words get replaced, and not just the first instance?

The code:

Sub exa()Dim _
rngLookFor          As Range, _
rngDataCell         As Range, _
strFormula          As String
    
    For Each rngLookFor In Range("D1:D99")
        For Each rngDataCell In Range("A1:C99")
            
            strFormula = rngDataCell.Text
            If ReturnReplacement(rngLookFor.Text, rngLookFor.Offset(, 1).Text, strFormula) Then
                rngDataCell.Value = strFormula
            End If
        Next
    Next
End Sub
    
Function ReturnReplacement(LookFor As String, _
                           ReplaceWith As String, _
                           FormulaString As String _
                           ) As Boolean
Static REX As Object '<--- RegExp
    
    If REX Is Nothing Then
        Set REX = CreateObject("VBScript.RegExp")
        REX.Global = False
        REX.IgnoreCase = True
    End If
    
    With REX
        .Pattern = "\b" & LookFor & "\b"
        
        If .Test(FormulaString) Then
            FormulaString = .replace(FormulaString, ReplaceWith)
            ReturnReplacement = True
        End If
    End With
End Function

Code above found from second to last post in: http://www.mrexcel.com/forum/excel-questions/468331-find-replace-exact-only-2.html

 

[JoeMo]

This is not a tweak, but an alternative (lightly tested) that you can try. Note that I have only included a few potential punctuation marks - you can expand the list as noted in the code if necessary.

Sub delonteReplace()
Dim c As Range, cel As Range, S As Variant, P As Variant, i As Long, j As Long
P = Array(",", ":", ";", "?", "!")  'Add any other punctuation marks that your text may contain
Application.Screenupdating = False
For Each c In Range(Cells(1, "D"), Cells(Rows.Count, "D").End(xlUp))
    For Each cel In Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("A:C")).Cells
        S = Split(cel.Value, " ")
        For i = LBound(S) To UBound(S)
            For j = LBound(P) To UBound(P)
                If S(i) = c.Value Then
                    S(i) = c.Offset(0, 1).Value
                    Exit For
                End If
                If S(i) = c.Value & P(j) Then
                    S(i) = c.Offset(0, 1).Value & P(j)
                    Exit For
                End If
            Next j
        Next i
        cel.Value = Trim(Join(S, " "))
        Erase S
    Next cel
Next c
Application.Screenupdating = True
End Sub

 

[delonte]

This is not a tweak, but an alternative (lightly tested) that you can try. Note that I have only included a few potential punctuation marks - you can expand the list as noted in the code if necessary.

Sub delonteReplace()
Dim c As Range, cel As Range, S As Variant, P As Variant, i As Long, j As Long
P = Array(",", ":", ";", "?", "!")  'Add any other punctuation marks that your text may contain
Application.Screenupdating = False
For Each c In Range(Cells(1, "D"), Cells(Rows.Count, "D").End(xlUp))
    For Each cel In Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("A:C")).Cells
        S = Split(cel.Value, " ")
        For i = LBound(S) To UBound(S)
            For j = LBound(P) To UBound(P)
                If S(i) = c.Value Then
                    S(i) = c.Offset(0, 1).Value
                    Exit For
                End If
                If S(i) = c.Value & P(j) Then
                    S(i) = c.Offset(0, 1).Value & P(j)
                    Exit For
                End If
            Next j
        Next i
        cel.Value = Trim(Join(S, " "))
        Erase S
    Next cel
Next c
Application.Screenupdating = True
End Sub

That worked like a charm - thank you very much!

 

[JoeMo]

That worked like a charm - thank you very much!

You are welcome - thanks for the reply.

 

[delonte]

Is there a way to include multiple words (phrases) into this 'find/replace' macro? So instead of replacing a single word like 'hello' can it also find and replace a phrase like "hello all"?

 

[JoeMo]

Is there a way to include multiple words (phrases) into this 'find/replace' macro? So instead of replacing a single word like 'hello' can it also find and replace a phrase like "hello all"?

If you want to replace phrases, it would be simpler to just use the Range.Replace Method. For example, if you wanted to replace "hello all" with "hi folks" in a paragraph in cell A1 you could use this:

Sub test()
Range("A1").Replace what:="hello all", replacement:="hi folks", lookat:=xlPart
End Sub

 

[delonte]

If you want to replace phrases, it would be simpler to just use the Range.Replace Method. For example, if you wanted to replace "hello all" with "hi folks" in a paragraph in cell A1 you could use this:

Sub test()
Range("A1").Replace what:="hello all", replacement:="hi folks", lookat:=xlPart
End Sub

There is a huge list of words/phrases though...do I need to put them each individually in the format you presented?

 

[JoeMo]

There is a huge list of words/phrases though...do I need to put them each individually in the format you presented?

Put your phrases to be replaced in column D and the replacement phrases in column E just as you did for the single word replacements .

Sub delonteReplace2()
'Assumes data in A1:C100, phrases to replace in column D starting in D1
'replacement phrases in column E starting in E1
Dim R As Range, i As Long
Set R = Range("A1:C100") 'This is your data range - change to suit your sheet
i = 1
Application.ScreenUpdating = False
Do
R.Replace what:=Range("D" & i).Value, replacement:=Range("E" & i).Value, lookat:=xlPart
i = i + 1
Loop Until Range("D" & i).Value = ""
Application.ScreenUpdating = True
End Sub

 

[Rick Rothstein]

This is not a tweak, but an alternative (lightly tested) that you can try. Note that I have only included a few potential punctuation marks - you can expand the list as noted in the code if necessary.

Sub delonteReplace()
Dim c As Range, cel As Range, S As Variant, P As Variant, i As Long, j As Long
P = Array(",", ":", ";", "?", "!")  'Add any other punctuation marks that your text may contain
Application.Screenupdating = False
For Each c In Range(Cells(1, "D"), Cells(Rows.Count, "D").End(xlUp))
    For Each cel In Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("A:C")).Cells
        S = Split(cel.Value, " ")
        For i = LBound(S) To UBound(S)
            For j = LBound(P) To UBound(P)
                If S(i) = c.Value Then
                    S(i) = c.Offset(0, 1).Value
                    Exit For
                End If
                If S(i) = c.Value & P(j) Then
                    S(i) = c.Offset(0, 1).Value & P(j)
                    Exit For
                End If
            Next j
        Next i
        cel.Value = Trim(Join(S, " "))
        Erase S
    Next cel
Next c
Application.Screenupdating = True
End Sub

I agree with the suggestion you make later about using Excel's Replace functionality for phrases as there is little chance for "false matches"; however, for finding stand-alone words and replacing them, I have a slightly more compact method (surprise...surprise) which should also work...

Sub delonteReplace2()
  Dim X, C As Range, Cel As Range, S As Variant
  Application.ScreenUpdating = False
  For Each C In Range("D1", Cells(Rows.Count, "D").End(xlUp))
    For Each Cel In Intersect(ActiveSheet.UsedRange, Columns("A:C"))
      For X = Len(Cel) - Len(C) + 1 To 1 Step -1
        If Mid(" " & Cel & " ", X, Len(C) + 2) Like "[!0-9A-Za-z]" & C & "[!0-9A-Za-z]" Then
          Cel = Replace(Cel, C.Value, C.Offset(, 1).Value)
        End If
      Next
    Next
  Next
  Application.ScreenUpdating = True
End Sub

 

[delonte]

Put your phrases to be replaced in column D and the replacement phrases in column E just as you did for the single word replacements .

Sub delonteReplace2()
'Assumes data in A1:C100, phrases to replace in column D starting in D1
'replacement phrases in column E starting in E1
Dim R As Range, i As Long
Set R = Range("A1:C100") 'This is your data range - change to suit your sheet
i = 1
Application.ScreenUpdating = False
Do
R.Replace what:=Range("D" & i).Value, replacement:=Range("E" & i).Value, lookat:=xlPart
i = i + 1
Loop Until Range("D" & i).Value = ""
Application.ScreenUpdating = True
End Sub

I confirm this indeed replaces phrases and it replaces multiple instances but it is not exact match. For example in column D I put 'he' 'hel' and 'hello'- then if the word "hello" shows up in columns A:C, it would only replace the 'he' part if that is higher up listed in the D column.

Also if in column D I only want to replace the word "hell" it would change the first four letters of the world "hello" if present in columns A:C.

If I change your code from lookat:=xlPart to lookat:=xlWhole - this again finds exact match for terms/phrases like I want but I get the same problem again of it only replacing the first instance of the word or phrase...