Multiple Substitute UDF

Have you ever written this formula?


I just did. It gets the job done, but it stinks. Here’s its replacement.

=subst(UPPER(A3),""," AND "," INC"," LLC"," LTD"," DBA"," CO"," ",".",",","&","-","/","'")

That’s a little better (assuming it works). On a side note, I wish Excel had built-in constants for formulas, so the above formula would look like this.

=subst(UPPER(A3),xlNULLSTRING," AND "," INC"," LLC"," LTD"," DBA"," CO",xlSPACE,".",xlCOMMA,"&","-","/",xlSINGLEQ)

Maybe I’ll create a Sheet template with those names defined. Or is that better in a Book template? Anyway, here’s the code for the poorly named Subst function.

Public Function Subst(text As String, NewText As String, ParamArray OldText() As Variant) As String

Dim vItem As Variant
Dim sReturn As String
Dim vArray As Variant

sReturn = text

vArray = OldText
BubbleSortLen vArray

For Each vItem In vArray
sReturn = Replace(sReturn, vItem, NewText, , , vbTextCompare)
Next vItem

Subst = sReturn

End Function

Public Sub BubbleSortLen(ByRef vArray As Variant)

Dim i As Long, j As Long
Dim sTemp As String

For i = LBound(vArray) To UBound(vArray) - 1
For j = i To UBound(vArray)
If Len(vArray(j)) > Len(vArray(i)) Then
sTemp = vArray(i)
vArray(i) = vArray(j)
vArray(j) = sTemp
End If
Next j
Next i

End Sub

The ParamArray argument takes as many arguments as you want to throw at it. For some reason, I couldn’t pass OldText by reference to the sorting procedure, so I had to copy it to another variable first. I sort the terms by length so that “corporation” gets replace before “corp”. Otherwise, I’ll be left with “oration”, which is just silly.

Once sorted, I simply replace all of the old with the one new, and return the string. It worked well for the one application I’ve used it for and it was a heck of a lot easier to update. Thoughts?

5 thoughts on “Multiple Substitute UDF

  1. Huh, I’m working on a project right now that this could make much easier.

    I’ll let you know how it works out.

    And, thanks! This is going to make my formulas much more powerful.

  2. One of my conventes is to start a UDF with F_.
    That makes them very easily detectable and disernable in the list of formulae; any interference with reserved terms is excluded as well.

    I’m not a fan of quotation marks, so if the items that have to be replaced will be stored in a string separated by pipelines it’s more to my liking.
    I found a ‘simpler’ method to replace in descending order of itemlength.

    Function F_Subst(c00 As String, c01 As String, c02 As String) As String
    F_Subst = c00

    sn = Split(c02, "|")
    sp = Evaluate("index(len({""" & Replace(c02, "|", """,""") & """}),)")

    For j = 0 To UBound(sn)
    F_Subst = Replace(F_Subst, sn(Application.Match(Application.Max(sp), sp, 0) - 1), c01, , 1)
    sp(Application.Match(Application.Max(sp), sp, 0)) = 0
    End Function

    in a cell:

    =F_subst("this is the text to replace","","is|ext |o repl")

  3. Hi all,
    Here’s an other approach using Regular Expression :

    Public Function F_Subst(text As String, NewText As String, ParamArray OldText() As Variant) As String

    Dim sReturn As String
    Dim vArray As Variant
    Dim sPattern As String
    Dim i As Integer

    Const RegExSpecialChar = "[\^$.|?*+(){}"

    sReturn = text
    vArray = OldText

    For i = LBound(vArray) To UBound(vArray)
    If InStr(1, RegExSpecialChar, vArray(i)) > 0 Then vArray(i) = "\" & vArray(i)
    Next i

    sPattern = "(" & Join(vArray, "|") & ")*"
    With CreateObject("VBScript.Regexp")
    .Pattern = sPattern
    .Global = True
    .Ignorecase = True 'optional
    sReturn = .Replace(sReturn, NewText)
    End With

    F_Subst = sReturn

    End Function

  4. I’ve had one of these in my library for a while now. Mine’s slightly different in application, though: it allows many-to-1 substitutions as well as 1-to-1 substitutions. The 1-to-1 version is the same as iterating multiple times. Here’s the code (hopefully this formats correctly…):

    Function GoodReplace(strExpression As String, ByVal varFind As Variant, ByVal varReplace As Variant, Optional lngStart As Long = 1, _
                         Optional lngCount As Long = -1, Optional vbCompare As VbCompareMethod = vbTextCompare) As String
    ' PURPOSE: More robust version of the Replace VBA function
    ' WRITTEN: Unknown
    ' UPDATED: 2012-12-28 -- updated boilerplate
    '          2013-10-29 -- pass varFind and varReplace ByVal to avoid inadvertently deleting the values, add blOneToOne
    ' INPUTS : strExpression -- expression to be fixed
    '          varFind -- single string or string array of the character(s) to find
    '          varReplace -- single string or string array of the character(s) to replace. Dimensions must be 0 (replace each
    '                          input with the same character) or the same as varReplace (replace characters on one-to-one basis)
    '          lngStart -- starting position of replacement
    '          lngCount -- number of substitutions to perform
    '          vbCompare -- Compare method (vbUseCompareOption, vbBinaryCompare, vbTextCompare)
    ' OUTPUT : Replaced string
      Dim i As Long
      Dim strReplaceVal As String
      Dim blOneToOne As String
      ' Force Find and Replace values to be Variant Arrays
      MakeVarArray varFind
      MakeVarArray varReplace
      GoodReplace = strExpression
      strReplaceVal = varReplace(0)
      blOneToOne = (UBound(varReplace) = UBound(varFind)) ' If bounds are the same, will use one to replace the other
      ' Loop through each varFind and replace as necessary
      For i = LBound(varFind) To UBound(varFind)
        If blOneToOne Then strReplaceVal = varReplace(i)
        GoodReplace = Replace(GoodReplace, varFind(i), strReplaceVal, lngStart, lngCount, vbCompare)
      Next i
    End Function
    Public Function MakeVarArray(ByRef var As Variant, Optional lngArrBase As Long = 0) As Boolean
    ' PURPOSE: Creates a variant array out of a variant. Used for parsing inputs which may be arrays or scalars
    ' WRITTEN: Unknown
    ' UPDATED: 2012-12-06 -- added boilerplate
    '          2012-12-28 -- tweaked behavior, no longer sends true/false and writes variables ByRef
    '          2013-10-25 -- Rework to pass array ByRef, output as pass/fail, update to match rework of MakeVarArray
    ' INPUTS : var -- variant (array or scalar) to be converted into an array
    '          lngArrBase -- array base number
    ' OUTPUTS: MakeVarArray -- array containing value(s) from var
      Dim arr As Variant
      If IsArray(var) Then
        ' Keep the same
        MakeVarArray = ShiftBase(var, lngArrBase)
        ' Force to be 1 dimensional array
        ReDim arr(lngArrBase To lngArrBase)
        arr(lngArrBase) = var
        var = arr
        MakeVarArray = True
      End If
    End Function
    Public Function ShiftBase(ByRef varArray As Variant, lngBase As Long) As Boolean
    ' PURPOSE: Shift the bounds of an array (1-dimensional only)
    ' WRITTEN: 2013-02-14
    ' UPDATED: 2013-10-25 -- change to pass variable ByRef, output true/false; additional reworking of code
    ' INPUTS : varArray -- array to be shifted (only takes single-dimension arrays right now)
    '        : lngBase -- new lower bound of array
    ' OUTPUT : varArray -- variant array with bounds shifted
    '          ShiftBase -- true/false if operation was successful
      Dim lngShift As Long
      Dim varTemp()
      Dim i As Long
      ShiftBase = False
      ' Check input (1-dimensional array or bust!)
      If Not IsArray(varArray) Then GoTo EXIT_FUNCTION
      If Not (ArrayDimensions(varArray) = 1) Then GoTo EXIT_FUNCTION
      ' Create temp array with new base
      lngShift = lngBase - LBound(varArray)
      ReDim varTemp(lngBase To UBound(varArray) + lngShift)
      ' Load temp array
      For i = LBound(varTemp) To UBound(varTemp)
        varTemp(i) = varArray(i - lngShift)
      Next i
      varArray = varTemp
      ShiftBase = True
    End Function
    Public Function ArrayDimensions(varArr As Variant) As Integer
    ' PURPOSE: Count number of dimensions in an array
    ' WRITTEN: 2013-10-24
    ' UPDATED:
    ' INPUTS : arr -- variant array to be tested
    ' OUTPUT : ArrayDimensions -- how many dimensions the array contains (0 means it is unallocated)
    ' SOURCE : Modified from
      Dim lngDimension As Long, lngTemp As Long
      On Error Resume Next
          lngDimension = lngDimension + 1
          lngTemp = UBound(varArr, lngDimension)
        Loop Until Err.Number <> 0
      On Error GoTo 0
      ArrayDimensions = lngDimension - 1
    End Function

    Yeesh, I didn’t realize until I started copy/pasting how subdivided my code is. Anyway, GoodReplace is easier to call from within VBA, but it can be called as a UDF as well: =goodreplace(“asdfg”,{“a”,”s”,”d”,”f”,”g”},{“B”,”r”,”y”,”a”,”n”})

Leave a Reply

Your email address will not be published. Required fields are marked *