Dynamic Find and Replace

[Joseph.Marro]

Hello,

I have a workbook with three worksheets: “Working File”, “Standard Abbreviations” and “Approved Abbreviations”
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
In the “Working File” I have a nomenclature field. The field will contain the description of an item.
<o></o>
EXAMPLE: VALVE BALL-TYPE PRESSURE CONTROL SEAWATER FLANGED 8 INCH
<o></o>
The “Standard Abbreviations” worksheet contains two columns, “A” and “B”. Column “A” is the full word to be found in the nomenclature string in the “Working File” and column “B” is the abbreviation. This work sheet does have column headers.
<o></o>
EXAMPLE: VALVE = VLV
<o></o>
The “Approved Abbreviations” work sheet is set up exactly like the “Standard Abbreviations” but contains a different list of words.
<o></o>
EXAMPLE: SEAWATER = SW
<o></o>
I would like the user to have the ability to select a cell or a range of cells and click a button to apply abbreviations.
<o></o>
Here is the tricky part, when the user clicks the button to apply abbreviations I want the “Standard Abbreviations” to be applied first and then evaluate the length of the modified nomenclature. If the new nomenclature is greater than 48 characters in length I want the macro to ask them if they want to apply the “Approved Abbreviations”. If they click “No” they exit the macro. If the click “Yes” I want the “Approved Abbreviations” to be applied from right-to-left until the string is less than 48 characters long.
<o></o>
Is this possible… or should I say plausible?
<o></o>
This is the code I have to do a simple find and replace based on one table. I know it isn't very pretty.
<o></o>

[FONT=Calibri][SIZE=3]Option Compare Text[/SIZE][/FONT]
Opt[FONT=Calibri][SIZE=3]ion Explicit[/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri][SIZE=3]Public Sub FindReplace()[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]Dim WS As Worksheet[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]Dim R_Find As Range[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]Dim R As Range[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]Dim i As Long[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]Dim strFind As String[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]Dim strReplace As String[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]Dim strTarget As String[/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri][SIZE=3]On Error GoTo Err_FindReplace[/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri][SIZE=3]Set WS = Worksheets("Sheet2")[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]i = WS.Cells(Rows.Count, "A").End(xlUp).Row[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]Set R_Find = WS.Range("A2:A" & i)[/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri][SIZE=3]For Each R In R_Find[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]   strFind = R.Value[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]   strReplace = R.Offset(0, 1).Value[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]   ActiveCell.Value = Replace(ActiveCell.Value, strFind, strReplace)[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]Next[/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri][SIZE=3]Exit_FindReplace:[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]Set WS = Nothing[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]Set R_Find = Nothing[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]Set R = Nothing[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]Exit Sub[/SIZE][/FONT]
 
[FONT=Calibri][SIZE=3]Err_FindReplace:[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]MsgBox Err.Number & " - " & Err.Description, vbCritical, "Error"[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]Resume Exit_FindReplace[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]Resume[/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri]End Sub[/FONT]

Thank you,

Joseph Marro

 

[Joseph.Marro]

Any help would be great. I am still quite lost.

Thank you,

Joseph Marro

 

[Joseph.Marro]

Ok, I think I may be on the right track. I have found a bit more robust "Find and Replace" code.

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("Standard Abbreviations").Range("A2")
    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

The next step is I need to evaluate the length of the output string. I am not sure if I should do this within the code or have a separate called procedure do it. <?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o></o>
Once the string has been evaluated, and a cell within the selection is found to have a length greater than 48 characters I need a pop up to appear notifying the user that a cell within the selection is longer than 48 characters. I guessing I would the link the next steps to VByes and VBno. If the user selects no then they would exit if they select yes then I would call a procedure to SPLIT the string that is greater than 48 characters into an array and pass each piece of the array (Ubound to Lbound, I think that will get me the desired right to left) to a search procedure to look for the array element in Sheet3 column A and if it is found replace the array element with the value in Sheet3 column B. If the array element was not found then it would repeat the process using the next array element. After each replacement the string would need to be reconstructed so that its length could be tested. If the sting is still greater than 48, loop until the string is less than 48.<o></o>
<o></o>
Am I on the right track here?<o></o>

Thank you,

Joseph Marro