Subscript vs. Superscript conflict

Question

_Background:

I'm trying to write a module to concatenate strings with it's formatting. Therefor I'm looking in all Font properties that could matter, including Subscript and Superscript.

---

_{Sample Data:}

Imagine in A1:

---

_{Sample Code:}

Sub Test()

With Sheet1.Range("B1")
    .Value = .Offset(0, -1).Value
    For x = 1 To .Characters.Count
        .Characters(x, 1).Font.Subscript = .Offset(0, -1).Characters(x, 1).Font.Subscript
        .Characters(x, 1).Font.Superscript = .Offset(0, -1).Characters(x, 1).Font.Superscript
    Next x
End With

End Sub

---

_Result:

---

_Question:

If I would go through this code step-by-step using F8 I can see the characters that are supposed to be subscript become subscript, but will loose it's properties value when the superscript value is passed. The other way around works fine, meaning the superscript properties stay intact.

This procedure is part of a larger procedure where for example I tried to convert this:

Sub ConcatStringsWithFormat()

Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim props(9) As Variant, arr As Variant
Dim rng As Range
Dim x As Long, y As Long: y = 0

Set rng = Sheet1.Range("A1:A3")
With Application
    .Trim (rng)
    arr = rng: arr = .Transpose(.Index(arr, 0, 1))
End With
    
For Each cell In rng
    If Len(cell) > 0 Then
        y = y + 1
        For x = 1 To cell.Characters.Count
            props(0) = cell.Characters(x, 1).Font.Bold
            props(1) = cell.Characters(x, 1).Font.ColorIndex
            props(2) = cell.Characters(x, 1).Font.FontStyle
            props(3) = cell.Characters(x, 1).Font.Italic
            props(4) = cell.Characters(x, 1).Font.Size
            props(5) = cell.Characters(x, 1).Font.Strikethrough
            props(6) = cell.Characters(x, 1).Font.Subscript
            props(7) = cell.Characters(x, 1).Font.Superscript
            props(8) = cell.Characters(x, 1).Font.TintAndShade
            props(9) = cell.Characters(x, 1).Font.Underline
            dict.Add y, props
            y = y + 1
        Next x
    End If
Next cell

With Sheet1.Cells(1, 2)
    .Value = Application.Trim(Join(arr, " "))
    For x = 1 To .Characters.Count
        If Mid(.Value, x, 1) <> " " Then
            .Characters(x, 1).Font.Bold = dict(x)(0)
            .Characters(x, 1).Font.ColorIndex = dict(x)(1)
            .Characters(x, 1).Font.FontStyle = dict(x)(2)
            .Characters(x, 1).Font.Italic = dict(x)(3)
            .Characters(x, 1).Font.Size = dict(x)(4)
            .Characters(x, 1).Font.Strikethrough = dict(x)(5)
            .Characters(x, 1).Font.Subscript = dict(x)(6)
            .Characters(x, 1).Font.Superscript = dict(x)(7)
            .Characters(x, 1).Font.TintAndShade = dict(x)(8)
            .Characters(x, 1).Font.Underline = dict(x)(9)
        End If
    Next x
End With

End Sub

Resulting in:

As you can see, it's just the subscript properties that get lost. Any thought on why this happens and also on how to overcome this? It's apparent that a cell will allow both properties to be true on different characters if you manually tried this.

Answer 1

Just test before setting those properties:

Sub Test()

With Sheet1.Range("B2")
    .Value = .Offset(0, -1).Value
    For x = 1 To .Characters.Count
      If .Offset(0, -1).Characters(x, 1).Font.Subscript Then
         .Characters(x, 1).Font.Subscript = True
      ElseIf .Offset(0, -1).Characters(x, 1).Font.Superscript Then
         .Characters(x, 1).Font.Superscript = True
      End If
    Next x
End With

End Sub