Multiple Substitute UDF

Posted on October 10, 2013March 17, 2018 by Dick Kusleika

Have you ever written this formula?

=SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(UPPER(A2),"AND","")," INC","")," LLC","")," LTD","")," DBA","")," ",""),".",""),",",""),"&",""),"-",""),"/",""),"'","")

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

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”

Michael says:

October 10, 2013 at 7:39 pm

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.
snb says:

October 11, 2013 at 3:33 am

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 Next End Function in a cell:
=F_subst("this is the text to replace","","is|ext |o repl")
JeanMarc says:

October 11, 2013 at 8:56 am

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

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)
  Else
    ' 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
  
EXIT_FUNCTION:
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 http://www.cpearson.com/excel/SortingArrays.aspx

  Dim lngDimension As Long, lngTemp As Long
  
  On Error Resume Next
    Do
      lngDimension = lngDimension + 1
      lngTemp = UBound(varArr, lngDimension)
    Loop Until Err.Number <> 0
  On Error GoTo 0

  ArrayDimensions = lngDimension - 1

End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

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)

Else

' 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

EXIT_FUNCTION:

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 http://www.cpearson.com/excel/SortingArrays.aspx

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”})