Dynamic Find and Replace

Joseph.Marro

Board Regular
Joined
Nov 24, 2008
Messages
153
Hello,

I have a workbook with three worksheets: “Working File”, “Standard Abbreviations” and “Approved Abbreviations”
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:eek:ffice:eek:ffice" /><o:p></o:p>
In the “Working File” I have a nomenclature field. The field will contain the description of an item.
<o:p></o:p>
EXAMPLE: VALVE BALL-TYPE PRESSURE CONTROL SEAWATER FLANGED 8 INCH
<o:p></o:p>
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:p></o:p>
EXAMPLE: VALVE = VLV
<o:p></o:p>
The “Approved Abbreviations” work sheet is set up exactly like the “Standard Abbreviations” but contains a different list of words.
<o:p></o:p>
EXAMPLE: SEAWATER = SW
<o:p></o:p>
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:p></o:p>
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:p></o:p>
Is this possible… or should I say plausible?
<o:p></o:p>
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:p></o:p>
Code:
[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
 

Some videos you may like

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.

Joseph.Marro

Board Regular
Joined
Nov 24, 2008
Messages
153
Ok, I think I may be on the right track. I have found a bit more robust "Find and Replace" code.

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-com:eek:ffice:eek:ffice" /><o:p></o:p>
<o:p></o:p>
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:p></o:p>
<o:p></o:p>
Am I on the right track here?<o:p></o:p>

Thank you,

Joseph Marro
 

Subscribe on YouTube

Watch MrExcel Video

Forum statistics

Threads
1,106,441
Messages
5,511,380
Members
408,845
Latest member
AwfulSpider

This Week's Hot Topics

  • Turn fraction around
    Hello I need to turn a fraction around, for example I have 1/3 but I need to present as 3/1
  • TIme Clock record reformatting to ???
    Hello All, I'd like some help formatting this (Tbl-A)(Loaded via Power Query) [ATTACH type="full" width="511px" alt="PQdata.png"]22252[/ATTACH]...
  • TextBox Match
    hi, I am having a few issues with my code below, what I need it to do is when they enter a value in textbox8 (QTY) either 1,2 or 3 the 3 textboxes...
  • Using Large function based on Multiple Criteria
    Hello, I can't seem to get a Large formula to work based on two criteria's. I can easily get a oldest value based one value, but I'm struggling...
  • Can you check my code please
    Hi, Im going round in circles with a Compil Error End With Without With Here is the code [CODE=rich] Private Sub...
  • Combining 2 pivot tables into 1 chart
    Hello everyone, My question sounds simple but I do not know the answer. I have 2 pivot tables and 2 charts that go with this. However I want to...
Top