Excel nested Substitute function macro ? (more than 64 nest)

Question

Hi I want to create a macro in Excel to replace characters of each word in a sheet to some different characters in new other sheet in the same cell. I have used substitude funtion but it allows me to use it for 64levels only. I have about 100 or more nests. Please guide....

For Example:

=
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
SUBSTITUTE(
G1,
"a","T"),
"b","p"),
"c","u"),
"d","d"),
"e","J"),
"f","v"),
"g","r"),
"h","j"),
"i","f"),
"j","i"),
"k","e"),
"l","b"),
"m","w"),
"n","B"),
"o","'"),
"p","g"),
"q","s"),
"r","o"),
"s",";"),
"t","N"),
"u","["),
"v","t"),
"w","k"),
"x","D"),
"y","/"),
"z","I"),
"0","0"),
"1","1"),
"2","2"),
"3","3"),
"4","4"),
"5","5"),
"6","6"),
"7","7"),
"8","8'"),
"9","9"),
"10","10"),
"A","n"),
"B","G"),
"C","S"),
"D","X"),
"E","U"),
"F","Y"),
"G","x"),
"H","Q"),
"I","h"),
"J","M"),
"K","y"),
"L","+"),
"M","z"),
"N","A"),
"O","""),
"P","c"),
"Q","E"),
"R","q"),
"S","P"),
"T","m"),
"U","{"),
"V","V"),
"W","K"),
"X",":"),
"Y","""),
"Z","}"),
"0","0"),
"%","#"),
"^","\"),
"&","|"),
"*","!"),
"(","("),
")",")"),
"=","&"),
"+","O'"),
"[","."),
"]","]")

Answer 1

You could add the following function in a module and then use it in a formula:

Function ReplaceSpecial(ByVal theString As String, ByVal find As String, ByVal replacement As String) As String
    Dim i As Integer, pos As Integer
    For i = 1 To Len(theString)
        pos = InStr(find, Mid(theString, i, 1))
        If pos > 0 Then Mid(theString, i, 1) = Mid(replacement, pos, 1)
    Next
    ReplaceSpecial = theString
End Function

Usage:

You can use it like a formula. Like this,

=ReplaceSpecial(G1, "abcdefghijklmnopqrstuvwxyz012345678910ABCDEFGHIJKLMNOPQRSTUVWXYZ0%^&*()=+[]", "TpudJvrjfiebwB'gso;N[tkD/I01234567890nGSXUYxQhMy+zA“”cEqPm{VK:}0#\|!()&O.]")

Or, you can use it like a macro. Implementation depends on where your find and replacement values are. Assuming they are in columns A and B respectively, you can add the following macro and use it.

Sub ReplaceSpecialMacro()
    Dim find As String, replacement As String, result As String
    find = Join(Application.Transpose(Range("A:A").Value), "")
    replacement = Join(Application.Transpose(Range("B:B").Value), "")
    result = ReplaceSpecial(ActiveCell, find, replacement)
    MsgBox result           '-- this is just for demo. you may put it in a cell etc.
End Sub

EDIT :

The following macro will run ReplaceSpecial on the all/selected cells:

Sub ReplaceSpecialMacro()
    Dim find As String, replacement As String, currentCell As Excel.Range
    find = "abcdefghijklmnopqrstuvwxyz012345678910ABCDEFGHIJKLMNOPQRSTUVWXYZ0%^&*()=+[]"
    replacement = "TpudJvrjfiebwB'gso;N[tkD/I01234567890nGSXUYxQhMy+zA“”cEqPm{VK:}0#\|!()&O.]"
    Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Select  '-- comment out this line if you want to run only on currently selected cells
    For Each currentCell In Selection
        currentCell = ReplaceSpecial(currentCell, find, replacement)
    Next
    MsgBox "Done!"
End Sub

HTH.

Answer 2

Python has a nice string method called translate. We can make something similar in VBA:

Function MakeTrans(Optional sourceChars As String, Optional targetChars As String, Optional deleteChars As String) As Object
    Dim i As Long, n As Long
    Dim c As String
    Dim D As Object

    Set D = CreateObject("Scripting.Dictionary")
    n = Len(sourceChars)
    For i = 1 To n
        c = Mid(sourceChars, i, 1)
        If Not D.Exists(c) Then
            D.Add c, Mid(targetChars, i, 1)
        End If
    Next i

    n = Len(deleteChars)
    For i = 1 To n
        c = Mid(deleteChars, i, 1)
        If Not D.Exists(c) Then
            D.Add c, ""
        End If
    Next i

    Set MakeTrans = D
End Function

Function Translate(sourceString As String, Optional sourceChars As String, Optional targetChars As String, Optional deleteChars As String, Optional transTable As Variant) As String
    Dim i As Long, n As Long
    Dim c As String, s As String
    Dim D As Object

    If IsMissing(transTable) Then
        Set D = MakeTrans(sourceChars, targetChars, deleteChars)
    Else
        Set D = transTable
    End If

    n = Len(sourceString)
    For i = 1 To n
        c = Mid(sourceString, i, 1)
        If D.Exists(c) Then
            s = s & D(c)
        Else
            s = s & c
        End If
    Next i
    Translate = s
End Function

This function takes a string of characters and a string of replacement characters, creates a dictionary in which every character in the first string is used as a key with the corresponding character in the second string as the value (if there is any such character -- otherwise the empty string is the value). Then the function loops through the source string, replacing each character by its dictionary equivalent, if it has an equivalent, otherwise leaving it alone. As an alternative calling sequence, you can separately create the translation dictionary and pass it directly to the translate function. Also, it is possible to explicitly pass a list of characters to be deleted -- which makes the function match the functionality of the Python method more exactly.

For example,

Sub test()
    Dim D As Object

    Debug.Print Translate("IBM", "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "ZABCDEFGHIJKLMNOPQRSTUVWXY")
    Debug.Print Translate("Elephant", deleteChars:="AEIOUaeiou")

    Set D = MakeTrans("ZABCDEFGHIJKLMNOPQRSTUVWXY", "ABCDEFGHIJKLMNOPQRSTUVWXYZ")

    Debug.Print Translate("HAL", , , , D)
    Debug.Print Translate("HAL", transTable:=D)

    Set D = MakeTrans("", "", deleteChars:="AEIOUaeiou")
    Debug.Print Translate("Elephant", transTable:=D)

End Sub

Which prints

HAL
lphnt
IBM
IBM
lphnt

The function is case sensitive, that could of course be tweaked. Using it in a loop on a range of cells with the same translation strings would be inefficient since it would be repeatedly creating and destroying the same dictionary, in that case you should use the other calling sequence.

Answer 3

Here is another way using Arrays which may be faster?

Let's say Col A in Sheet1 has your characters that need to be replaced and Col B has the replacement characters. You may add as many as you want. For demonstration purpose, I will use 2 letters in Col A.

Now Try this

Sub Sample()
    Dim ws As Worksheet
    Dim s As String
    Dim MyaR As Variant, sAr As Variant
    Dim lRow As Long, i As Long, j As Long

    '~~> This is our string
    s = "Siddharth"

    ReDim sAr(1 To Len(s))

    For i = 1 To Len(s)
        sAr(i) = Mid(s, i, 1)
    Next i

    Set ws = Sheet1

    With ws
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        MyaR = .Range("A1:B" & lRow).Value

        For i = 1 To Len(s)
            For j = 1 To lRow
                If sAr(i) = MyaR(j, 1) Then
                    sAr(i) = MyaR(j, 2)
                    Exit For
                End If
            Next j
        Next i
    End With

    '~~> Output new value which is aibbharth
    Debug.Print Join(sAr, "")
End Sub

Answer 4

Here is a very simple example that does 75 substitutions:

Public Function scramble(SIN As String) As String
    Dim temp As String, L As Long, i As Long
    Dim CH As String

    s1 = "0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz"
    s2 = "FPmbaXO`qwJz^_v:EY7yVehU6TDjBN45k]oplxMS8HA;[\u0ZfCri2>I9?n@=ts1QG3gd<LRcWK"
    L = Len(SIN)
    scramble = ""
    temp = ""

    For i = 1 To L
        CH = Mid(SIN, i, 1)
        j = InStr(s1, CH)
        If j = 0 Then
            temp = temp & CH
        Else
            temp = temp & Mid(s2, j, 1)
        End If
    Next i

    scramble = temp
End Function

The original characters are in the variable s1 and the substituted characters are in the variable s2. For example: