[VBA][XL2010] Search and Replace with Multiple Search Values

[chartzell]

I'd like to know how to do a search and replace by checking each cell in a given column against an array of values provided by the user. Specifically, I have a user that needs to find several (but not all) model numbers with the format of "\b([0-9]?[A-Z]{2,3}).*" and add letters to the end of the parenthetical string.

I have limited experience with VBA (I'd normally pull out the column and handle it with sed, but that's not an option for my user) so any snippets of code, relevant resource pages, or suggestions of alternate ways to handle the problem would be greatly appreciated.


Edit:

This issue has been solved (thanks in large part to hippiehacker). For anyone searching for a similar problem, here is my code. It's VBA macro that selects a column based on the value in the header, checks each cell in that column for multiple values given by the user, and does a regex replace on the contents of the cell if it finds any of the values given previously.

Sub AddZ()
    Dim lRow, lCol As Long
    Dim myArray() As Variant, myArrayPointer As Long '//myArray will hold user-input search terms
    Dim uiValue As Variant
    Dim oRegReplace As Object
    Set oRegReplace = CreateObject("VBscript.regexp")
    
    oRegReplace.Pattern = "\b([0-9]?[A-Z]{1,3})[^ \b]" '//RegEx search pattern to be used
    oRegReplace.Global = True '//Set this to false to disable global replace (will only replace first occurrence)
    
    lRow = 2
    lCol = Rows(1).Find(What:="*Model*", After:=Cells(1, 1), LookIn:=xlFormulas, LookAt _
    :=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
    '//^ This line searches column headers for "*Model*" and assigns the column number to lCol

    ReDim myArray(1 To 1)
    myArrayPointer = 1

    uiValue = 1

    Do
        uiValue = Application.InputBox("Model Number to Modify")

        If myArrayPointer > UBound(myArray) Then
            ReDim Preserve myArray(1 To myArrayPointer)
        End If
        myArray(myArrayPointer) = uiValue

        If uiValue <> False Then
            myArrayPointer = myArrayPointer + 1
        End If

        Loop Until uiValue = False

    If myArrayPointer = 0 Then
        MsgBox "Nothing Entered"
    Else
        ReDim Preserve myArray(1 To myArrayPointer)
    End If
    
    Do
        For Each ModelNum In myArray()
            If ModelNum = ActiveSheet.Cells(lRow, lCol).Value Then
                CurrModel = ModelNum
                temp = oRegReplace.Replace(ActiveSheet.Cells(lRow, lCol).Value, "$1" & "Z") '//This is where the replace happens
                ActiveSheet.Cells(lRow, lCol).Value = temp
                Exit For
            End If
        Next
        
        lRow = lRow + 1
    Loop Until Len(Cells(lRow, lCol)) = 0

End Sub

Cody Hartzell
System Administrator at
Clarion Bathware

 

[chartzell]

Thanks for the code. I've already headed home for the weekend and don't have the resources available to work on or test it here, but I'll be sure to see what I can do with this when I get back into the office on Monday morning.

 

[chartzell]

Alright, I've nearly got it. I just need to know how to implement the regex to do my replacement inside of this loop.

    Do
        For Each ModelNum In myArray()
            If ModelNum = ActiveSheet.Cells(lRow, lCol).Value Then
                CurrModel = ModelNum
                '// Do regex replace to "ActiveSheet.Cells(lRow, lCol).Value"
                Exit For
            End If
        Next
        
        lRow = lRow + 1
    Loop Until Len(Cells(lRow, lCol)) = 0

 

[hippiehacker]

like this should do

    Do
        For Each ModelNum In myArray()
            If ModelNum = ActiveSheet.Cells(lRow, lCol).Value Then
                CurrModel = ModelNum
                 temp = RegExpTest(ActiveSheet.Cells(lRow, lCol).Value, "[A-Z][A-Z][0-9][0-9][0-9][0-9][A-Z][A-Z]*", "z")
                 ActiveSheet.Cells(lRow, lCol).Value = temp
            End If
        Next
        
        lRow = lRow + 1
    Loop Until Len(Cells(lRow, lCol)) = 0

this needs to be placed in a module

Function RegExpTest(strValue As String, strPattern As String, strAdd As String)
    Dim regEx, Match, Matches, s

    ' Create the regular expression.
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Pattern = strPattern
    regEx.IgnoreCase = True
    regEx.Global = True

    ' Do the search.
    Set Matches = regEx.Execute(strValue)

    ' Iterate through the Matches collection.
    s = ""
    For Each Match In Matches
      's = s & "Match found at position "
      's = s & Match.FirstIndex + 1 & ".  "
      's = s & "Match Length is "
      's = s & Match.Length & "."
      's = s & vbCrLf
      If u = "" Then
      s = Left(strValue, Match.FirstIndex + 2) & strAdd
      t = Right(strValue, Len(strValue) - (Match.FirstIndex + 1 + 2))
      u = s & t
      Else
      s = Left(u, Match.FirstIndex + 2) & strAdd
      t = Right(u, Len(u) - (Match.FirstIndex + 1 + 2))
      u = s & t
      End If
    Next

    RegExpTest = u
End Function

 

[chartzell]

Thanks for the help hippiehacker. I ended up not using the function you provided, but seeing it as well as its usage saved me a lot of headache-inducing searching for some stupid issues I was having with my solution (e.g. trying to use the regex directly instead of "temp = regex.replace(foo, bar)").

I'll update my first post with my code for anyone else searching for a similar solution.

 

[hippiehacker]

good to know I will remember this post if I have any regex issues again