Inserting the tags in the middle of the string in cell

Question

I have the code which iterates through every character in string from a cell in first worksheet, checks whether it is formatted (bold, underlined, coloured) and put my custom tags (eg. {b} and {eb}) in right position and paste it to another cell in second worksheet. I can't figure out how to make my tags appear in the right place. I tried out with LEFT and RIGHT, MID functions, but didn't succeed.

Dim b, u, c As Boolean
Dim x As Integer

b = False
u = False
c = False

Dim bytes() As Byte
Dim example As String

example = FCTitle.Offset(0, 1).Value
bytes = example

   If FCTitle.Offset(0, 1).Value <> "" Then
    Debug.Print "start"

       For x = LBound(bytes) To UBound(bytes) Step 2
            With FCTitle.Offset(0, 1).Characters(x, 1)

               If .Font.Bold = True And b = False Then
                    s1Title.Offset(-1, 1).Value = s1Title.Offset(-1, 1).Value & "{b}"
                    b = True
                    Debug.Print s1Title.Offset(-1, 1).Value

            End If
            If .Font.Underline = 2 And u = False Then
                s1Title.Offset(-1, 1).Value = s1Title.Offset(-1, 1).Value & "{u}"  '
               u = True
                Debug.Print s1Title.Offset(-1, 1).Value
            End If
            If .Font.ColorIndex > 0 And .Font.ColorIndex <> 1 And c = False Then
                s1Title.Offset(-1, 1).Value = s1Title.Offset(-1, 1).Value & "{c}" ' & Right(bytes, UBound(bytes) - x)
               c = True
                Debug.Print s1Title.Offset(-1, 1).Value
            End If
            If (.Font.ColorIndex < 0 Or .Font.ColorIndex = 1) And c = True Then
            s1Title.Offset(-1, 1).Value = s1Title.Offset(-1, 1).Value & "{ec}"
                c = False
                Debug.Print s1Title.Offset(-1, 1).Value
            End If
            If .Font.Underline <> 2 And u = True Then
                s1Title.Offset(-1, 1).Value = s1Title.Offset(-1, 1).Value & "{eu}"
                u = False
                Debug.Print s1Title.Offset(-1, 1).Value
            End If
            If .Font.Bold = False And b = True Then
                s1Title.Offset(-1, 1).Value = s1Title.Offset(-1, 1).Value & "{eb}"
                b = False
                Debug.Print s1Title.Offset(-1, 1).Value
            End If
            If Asc(.Text) = 10 Then
                s1Title.Offset(-1, 1).Value = s1Title.Offset(-1, 1).Value & .Text
                Debug.Print s1Title.Offset(-1, 1).Value
            End If

        End With

      Next x
        If c = True Then
        s1Title.Offset(-1, 1).Value = s1Title.Offset(-1, 1).Value & "{ec}"
        Debug.Print s1Title.Offset(-1, 1).Value
        c = False

        End If
        If u = True Then
        s1Title.Offset(-1, 1).Value = s1Title.Offset(-1, 1).Value & "{eu}"
        Debug.Print s1Title.Offset(-1, 1).Value
        u = False

        End If
        If b = True Then
        s1Title.Offset(-1, 1).Value = s1Title.Offset(-1, 1).Value & "{eb}"
        Debug.Print s1Title.Offset(-1, 1).Value
        b = False

        End If
        Debug.Print "koniec"     
    End If

So far values printed in console after each change in string look like below. Word "SUPER" is bolded, underlined and coloured red, so my expected output should be "{b}{u}{c}SUPER{eb}{eu}{ec} aaa {b}{u}{c}SUPER{eb}{eu}{ec}". Sorry if I did something wrong, it is my first post here.

start
SUPER  aaa  SUPER{b}
SUPER  aaa  SUPER{b}{c}
SUPER  aaa  SUPER{b}{c}{ec}
SUPER  aaa  SUPER{b}{c}{ec}{u}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}{eu}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}{eu}{ec}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}{eu}{ec}{eb}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}{eu}{ec}{eb}{b}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}{eu}{ec}{eb}{b}{c}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}{eu}{ec}{eb}{b}{c}{u}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}{eu}{ec}{eb}{b}{c}{u}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}{eu}{ec}{eb}{b}{c}{u}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}{eu}{ec}{eb}{b}{c}{u}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}{eu}{ec}{eb}{b}{c}{u}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}{eu}{ec}{eb}{b}{c}{u}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}{eu}{ec}{eb}{b}{c}{u}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}{eu}{ec}{eb}{b}{c}{u}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}{eu}{ec}{eb}{b}{c}{u}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}{eu}{ec}{eb}{b}{c}{u}{ec}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}{eu}{ec}{eb}{b}{c}{u}{ec}{eu}
SUPER  aaa  SUPER{b}{c}{ec}{u}{c}{eu}{ec}{eb}{b}{c}{u}{ec}{eu}{eb}
koniec

Answer 1

This worked for me (written as a UDF)

Some of the character properties are a bit tricky - for example Bold can be null, False, or True, and ColorIndex doesn't seem that reliable.

Function Coded(r As Range)
    Dim rv As String, b As Boolean, c As Boolean, u As Boolean
    Dim bC As Boolean, cC As Boolean, uC As Boolean
    Dim i As Long, txt

    For i = 1 To Len(r.Value)
        'get this character's properties
        With r.Characters(i, 1)
            bC = Not (IsNull(.Font.Bold) Or .Font.Bold = False)
            uC = (.Font.Underline = 2)
            cC = (.Font.ColorIndex <> -4105) '-4105=automatic
            txt = .Text
        End With
        'opening or closing any tags?
        If c <> cC Then
            rv = rv & IIf(cC, "{c}", "{ec}")
            c = cC
        End If
        If b <> bC Then
            rv = rv & IIf(bC, "{b}", "{eb}")
            b = bC
        End If
        If u <> uC Then
            rv = rv & IIf(bC, "{u}", "{eu}")
            u = uC
        End If
        rv = rv & txt
    Next i

    'close any open tags
    If b Then rv = rv & "{eb}"
    If c Then rv = rv & "{ec}"
    If u Then rv = rv & "{eu}"

    Coded = rv
End Function