replace text

Hi charm1

Might be an easier solution????
Put this in Sheet1.Module

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B11:I17")) Is Nothing Then Macro
End Sub

And this in a std module

Option Explicit

Sub Macro()
Dim cell As Range, rng As Range
Dim charset As Integer
Dim char As String
Application.ScreenUpdating = False
Sheet1.Range("B20:I26") = ""
For Each cell In Sheet1.Range("B11:I17")
    For charset = 1 To Len(cell) Step 2
        char = Mid(cell, charset, 2)
        Set rng = Sheet1.Range("B6:E6").Find(char, LookIn:=xlValues, lookat:=xlWhole)
        If Not rng Is Nothing Then
            cell.Offset(9, 0) = cell.Offset(9, 0) & rng.Offset(1, 0)
        End If
    Next charset
Next cell
Application.ScreenUpdating = True
End Sub

Enter your Original text characters into any cell in Range("B11:I17")

Change this line of code....

For charset = 1 To Len(cell) Step 2
        char = Mid(cell, charset, 2)

to this

For charset = 1 To Len(cell)
        char = Mid(cell, charset, 1)