C
ChasePenelli
Alright So i have a macro to do my bidding...I think : This is for
changing all the abbriviations in column 1 to the words in column 2 of
sheet 2 INTO sheet one's information... So my question is how can i
change it to search (change range?) to the one on my doucument. The
dementions are as follows: From Column A - CU and it is 763 rows! :
Well here is the Macro right now... Just asking is this will change the
items from sheet2 on sheet1 and how to make it search over that vast
amount of space!
Thanks everyone for your help thus far!~
Sub Replacer()
'Does a Find and Replace on whole words throughout the selected
range. Uses a table of _
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
'Populate the array variable Y with Find/Replace strings. Default
source is Sheet2, A1:Bxx
On Error Resume Next
Set rg = Worksheets("Sheet2").Range("F1")
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
'.IgnoreCase = True 'True if search is case insensitive.
False otherwise
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 'Replace cell values with the edited strings
End Sub
changing all the abbriviations in column 1 to the words in column 2 of
sheet 2 INTO sheet one's information... So my question is how can i
change it to search (change range?) to the one on my doucument. The
dementions are as follows: From Column A - CU and it is 763 rows! :
Well here is the Macro right now... Just asking is this will change the
items from sheet2 on sheet1 and how to make it search over that vast
amount of space!
Thanks everyone for your help thus far!~
Sub Replacer()
'Does a Find and Replace on whole words throughout the selected
range. Uses a table of _
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
'Populate the array variable Y with Find/Replace strings. Default
source is Sheet2, A1:Bxx
On Error Resume Next
Set rg = Worksheets("Sheet2").Range("F1")
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
'.IgnoreCase = True 'True if search is case insensitive.
False otherwise
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 'Replace cell values with the edited strings
End Sub