Multi-Replace at once vb6

Question

Suppose I have a string "appleapple". I want to replace all 'a' by 'e' and all 'e' by 'a' in vb6.

My desired output is "epplaeppla"

If I use:

str = "appleapple"
str = Replace(str, "a", "e")
str = Replace(str, "e", "a")

But

Output will be : "applaappla"

Is there any better way to multi-replace letters or words where one replacement is not affected by another like in this type of case? Not just for the case of two replacements but say for multiple cases where many replacements affect one another.

Answer 1

The safest and easiest way is to use a two step replacement where you temporarily substitute unused characters in the ASCII chart (at the top of the chart - ASCII CODEs 0 - 31) and then replace those with your final choices.

See Full ASCII Chart

See image below for sample of typically unused chars

This should work for single character as well as multiple char replacements.

Option Explicit

' Use this to distinguish between upper and lower case replacements
Option Compare Binary

Public Sub SafeMultiReplace()

    ' use something not in list of characters being searched or replaced
    Const DELIM         As String = ","

    Const START_STRING  As String = "appleappleAPPLE"

    Dim ReplaceString   As String
    Dim OutputString    As String

    Dim ChangeVars      As Variant
    Dim ReplaceVars     As Variant

    Dim i               As Integer

    ' These two arrays must match total vars
    ' Load array of many characters you want to change From
    ChangeVars = Split("a,e", DELIM)

    ' Load array of many characters you want to change to
    ReplaceVars = Split("e,a", DELIM)

    OutputString = START_STRING

    ' Replace original chars with unused chars
    For i = LBound(ChangeVars) To UBound(ChangeVars)
        OutputString = Replace(OutputString, ChangeVars(i), Chr(i))
    Next i

    ' Replace unused chars with replacement chars
    For i = LBound(ReplaceVars) To UBound(ReplaceVars)
        OutputString = Replace(OutputString, Chr(i), ReplaceVars(i))
    Next i

    Debug.Print "Final Output: " & OutputString
    'Final Output: epplaepplaAPPLE

End Sub

Answer 2

I came up with a method that:

• would not lead to double changing of characters (a to b then back again)
• is relatively fast (1000 14-character long strings edited in less than a second)
• is written fairly simply (although it might be possible to merge the first two array loops for the sake of brevity)
• and best of all, has incredibly high bounds. The upper bound on how many character types you could substitute is larger than count(all Unicode characters).

Currently I think it is case sensitive, but could be converted to non case sensitive.
In the meantime, if you want to switch both Ucase and Lcase, just include both substitutions in your substitution list -> ("a,b;A,B;b,a;B,A")

Option Explicit
Function ReplaceLetters(strText As String, SubList As String) As String
    
    'Note, Sub List Must be in format: _
        "CharacterToReplace_1,ReplaceWith_1;CharacterToReplace_2,ReplaceWith_2;CharacterToReplace_3,ReplaceWith_3 ... " _
        "a,e;b,c"
    
    Dim X As Long
    Dim Y As Long
    Dim Replacements
    Dim CharArray
    
    'Split substitution list by semicolons
    Replacements = Split(SubList, ";")
    
    'Resize Character Array to fit all data
    ReDim CharArray(0 To 1, 0 To UBound(Replacements))
    
    'Split replacement list into character array
    For X = 0 To UBound(Replacements)
        CharArray(0, X) = Split(Replacements(X), ",")(0)
        CharArray(1, X) = Split(Replacements(X), ",")(1)
    Next X
    
    'Make replacements,
    For Y = 1 To Len(strText)
        For X = 0 To UBound(Replacements)
            If CharArray(0, X) = Mid(strText, Y, 1) Then
                strText = WorksheetFunction.Replace(strText, Y, 1, CharArray(1, X))
                Exit For ' Required so it doesn't change back
            End If
        Next X
    Next Y
    
    ReplaceLetters = strText
    
End Function
Sub TestResplacement()

    Dim I As Long
    Dim Start
    
    Start = Timer
    
    For I = 1 To 1000
        ' > Base Text = appleappleoboc , substitute a for e, e for a, b for c, c for b
        Debug.Print ReplaceLetters("appleappleoboc", "a,e;e,a;b,c;c,b")
    Next I
    
    'Prints 1000 sustitutions in around 0.90 seconds
    Debug.Print Format(Timer - Start, "0.000")
    
End Sub

For Example:

    Debug.Print ReplaceLetters("appleappleoboc", "a,e;e,a;b,c;c,b")
    ' Returns: "epplaepplaocob"