Find and replace subscripts and superscripts in MS Excel

Question

I would like to find all numbers and formulas which contain subscripts and superscripts in excel cells and replace it with html tags for subscripts and superscripts.

Eg. cell containing a ² + (b ³ - c) would be replaced as:

 a<sup>2</sup> + (b<sup>3</sup> - c) 

Thanks a lot.

Answer 1

As far as I try, that one works always but fail on the first character. So if the firs character is Subscript or Superscript, it will fail.

The code it is for the superscript case. For the subscript case, just change .Font.Subscript by .Font.Superscript and whatever code on html ( <sup> on the superscript).

Sub test()
Dim ColNo, RowNo As Long
Dim Pos(500) As Integer
Dim Str(500) As String
Dim sType(500) as String
Dim NewStr As String

Set ws1 = Worksheets("Hoja1")
Set ws2 = Worksheets("Hoja2")
ws1.Activate

With ws1
    RowNo = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
    ColNo = .UsedRange.SpecialCells(xlCellTypeLastCell).Column
    l = 2
    For i = 1 To ColNo
        For j = 1 To RowNo
            Pos(1) = 1
            For k = 1 To Len(.Cells(j, i).Value2) - 1
                If .Cells(j, i).Characters(k + 1, 1).Font.Superscript = True Then
                    Pos(l) = k + 1
                    sType(l) = "Sup"
                    l = l + 1
                ElseIf .Cells(j, i).Characters(k + 1, 1).Font.Subscript = True Then
                    Pos(l) = k + 1
                    sType(l) = "Sub"
                    l = l + 1
                End If
            Next
            For k = 1 To l - 1
                If Pos(k + 1) > Pos(k) Then
                    If sType(l + 1) = "Sup" Then
                        Str(2 * k) = Mid(.Cells(j, i).Value2, Pos(k), Pos(k + 1) - Pos(k))
                        Str(2 * k - 1) = Mid(.Cells(j, i).Value2, Pos(k + 1), 1)
                        Str(2 * k - 1) = "<sup>" & Str(2 * k - 1) & "</sup>"
                        NewStr = NewStr & Str(2 * k) & Str(2 * k - 1)
                    ElseIf sType(l + 1) = "Sub" Then
                        Str(2 * k) = Mid(.Cells(j, i).Value2, Pos(k), Pos(k + 1) - Pos(k))
                        Str(2 * k - 1) = Mid(.Cells(j, i).Value2, Pos(k + 1), 1)
                        Str(2 * k - 1) = "<sub>" & Str(2 * k - 1) & "</sub>"
                        NewStr = NewStr & Str(2 * k) & Str(2 * k - 1)
                    End If
                End If
            Next
            If NewStr <> "" Then
                NewStr = NewStr + Mid(.Cells(j, i).Value2, _
                                  Pos(l - 1), Len(.Cells(j, i).Value2) - Pos(l - 1))
            Else
                NewStr = .Cells(j, i).Value2
            End If
            ws2.Cells(j, i).Value2 = NewStr
            NewStr = ""
            For k = 1 To l - 1
                Pos(k) = 0
                sType(k) = ""
                Str(2 * k) = ""
                Str(2 * k - 1) = ""
            Next
            l = 2
        Next
    Next
End With

End Sub

Hope it helps

Answer 2

Try this one:

Sub test()
Dim ColNo, RowNo As Long
Dim NewStr As String

Set ws1 = Worksheets("q")
Set ws2 = Worksheets("q-a")
ws1.Activate

With ws1
    RowNo = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
    ColNo = .UsedRange.SpecialCells(xlCellTypeLastCell).Column

    For i = 1 To ColNo
        For j = 1 To RowNo
            l = 1
            NewStr = .Cells(j, i).Value2
            For k = 1 To Len(.Cells(j, i).Value2) - 1
                If .Cells(j, i).Characters(k + 1, 1).Font.Superscript = True Then
                    NewStr = Mid(NewStr, 1, k - 1 + l) & "<sup>" & Mid(.Cells(j, i) _ 
                           .Value2, k + 1, 1) & "</sup>" & Mid(.Cells(j, i).Value2, _
                                  k + 2, Len(.Cells(j, i).Value2) - (k + 1))
                    l = l + 11
                ElseIf .Cells(j, i).Characters(k + 1, 1).Font.Subscript = True Then
                    NewStr = Mid(NewStr, 1, k - 1 + l) & "<sub>" & Mid(.Cells(j, i)._ 
                            Value2, k + 1, 1) & "</sub>" & Mid(.Cells(j, i).Value2, _
                                  k + 2, Len(.Cells(j, i).Value2) - (k + 1))
                    l = l + 11
                End If
            Next
            l = 1
            For k = 1 To Len(NewStr) - 1
                If InStr(k, NewStr, "</sup><sup>", vbBinaryCompare) = k Then
                    NewStr = Mid(NewStr, 1, k - 1) & Mid(NewStr, k + 11, Len(NewStr) - (k + 10))
                ElseIf InStr(1, NewStr, "</sub><sub>", vbBinaryCompare) <> 0 Then
                    NewStr = Mid(NewStr, 1, k - 1) & Mid(NewStr, k + 11, Len(NewStr) - (k + 10))
                End If
            Next
            ws2.Cells(j, i).Value2 = NewStr
            NewStr = ""
        Next
    Next
End With

End Sub

According with the new information, I just make it simpler.

Hope it helps