Sub Replacer()
Find And Replace strings taken from Sheet2 columns A And B _
Uses regular expressions For search To make sure found strings are complete words _
Uses arrays For speed For range To be searched And For source of Find/Replace strings. _
Note: will wipe out all formulas In the selected range!
Dim RgExp As Object
Dim rg As Range
Dim X As Variant, Y As Variant
Dim i As Long, j As Long, k As Long, nColumns As Long, nFindReplace As Long, nRows As Long
Dim FindReplacePrompt As String
FindReplacePrompt = "I couldn't find the Find/Replace strings at Sheet2!A1:Bxx. Please select them now." & _
" No blanks allowed in first column!"
If Selection.Cells.Count = 1 Then
If Selection = "" Then
MsgBox "Please select some cells to run the macro on, then try again"
Exit Sub
Else
ReDim X(1 To 1, 1 To 1)
X(1, 1) = Selection
End If
Else
X = Selection.Value
End If
On Error Resume Next
Set rg = Worksheets("Sheet2").Range("A1")
If rg Is Nothing Then
Set rg = Application.InputBox(prompt:=FindReplacePrompt, Title:="Source of Find/Replace strings", Type:=8)
If rg Is Nothing Then Exit Sub
Else
If rg.Cells(1, 1) = "" Then
Set rg = Application.InputBox(prompt:=FindReplacePrompt, Title:="Source of Find/Replace strings", Type:=8)
If rg Is Nothing Then Exit Sub
Else
Set rg = Range(rg, rg.End(xlDown).Offset(0, 1))
End If
End If
On Error GoTo 0
Y = rg.Value
nFindReplace = UBound(Y)
Set RgExp = CreateObject("VBScript.RegExp")
With RgExp
.Global = True
End With
nRows = UBound(X)
nColumns = UBound(X, 2)
For i = 1 To nFindReplace
RgExp.Pattern = "\b" & Y(i, 1) & "\b"
For j = 1 To nRows
For k = 1 To nColumns
X(j, k) = RgExp.Replace(X(j, k), Y(i, 2))
Next k
Next j
Next i
Set RgExp = Nothing
Selection.Value = X
End Sub
Sub Replacer2()
Find And Replace strings taken from Sheet2 columns A And B _
Uses regular expressions For search To make sure found strings are complete words _
Loops through the cells To be searched using an array For source of Find/Replace strings _
Tries To preserve As many formulas As possible (will wipe out formulas If the result _
contains a String on the Find list).
Dim RgExp As Object
Dim cel As Range, rg As Range
Dim Y As Variant, tmp As Variant
Dim i As Long, nFindReplace As Long
Dim FindReplacePrompt As String
FindReplacePrompt = "I couldn't find the Find/Replace strings at Sheet2!A1:Bxx. Please select them now." & _
" No blanks allowed in first column!"
If Selection.Cells.Count = 1 And Selection.Cells(1, 1) = "" Then
MsgBox "Please select some cells to run the macro on, then try again."
Exit Sub
End If
On Error Resume Next
Set rg = Worksheets("Sheet2").Range("A1")
If rg Is Nothing Then
Set rg = Application.InputBox(prompt:=FindReplacePrompt, Title:="Source of Find/Replace strings", Type:=8)
If rg Is Nothing Then Exit Sub
Else
If rg.Cells(1, 1) = "" Then
Set rg = Application.InputBox(prompt:=FindReplacePrompt, Title:="Source of Find/Replace strings", Type:=8)
If rg Is Nothing Then Exit Sub
Else
Set rg = Range(rg, rg.End(xlDown).Offset(0, 1))
End If
End If
On Error GoTo 0
Y = rg.Value
nFindReplace = UBound(Y)
Set RgExp = CreateObject("VBScript.RegExp")
With RgExp
.Global = True
End With
Application.ScreenUpdating = False
For Each cel In Selection
For i = 1 To nFindReplace
RgExp.Pattern = "\b" & Y(i, 1) & "\b"
tmp = RgExp.Replace(cel.Value, Y(i, 2))
If cel.HasFormula Then
If cel.Value <> tmp Then cel.Formula = tmp
Else
cel.Value = tmp
End If
Next i
Next cel
Set RgExp = Nothing
Application.ScreenUpdating = True
End Sub
|