superscript letters in vba string variable - excel

Question

I am looking for how to super/subscript a letter/digit in a VBA string variable. I am working in excel with charts that have axes, titles and chart titles that require s-scripting. Additionally, there is a formula to go in a textbox:
Cpt = Cp0 * e^(-ket) where all the p's, t's and 0 are subscripts. The entire expression, (-ket) is superscripted with embedded subscripting for the e (the e between the k & t). Finally, all the specially formatted string variables will be copied to PowerPoint variables via clipboard/gettext.
Any help / guidance is greatly appreciated.
Pat K.

Answer 1

It is workaround Idea only and the code may not be useful for your purpose depending on source and destination of the data and may be treated as demo only. i have only used excel cells and Text Boxes on a sheet as destination and used PowerPoint Text Boxes as target.
The simple approach is that while picking up String from formatted cells/Text Boxes from excel to a variable, Font Subscript, Superscript information is also to be picked up in a parallel variable (here in a 2D Array). The same font information may be used while writing in PowerPoint. The demo idea have to be Modified/Converted to suit your need.
Demo Screen shot
The demo code
Sub Sscript()
Dim CellStr() As Variant
Dim Rng As Range, Cell As Range
Dim shp As Shape
Dim VarNo As Long, i As Long, j As Long, Txt As String, FntInfo As String
Set Rng = Range("C3:C7") 'Range used for collecting input data and font information for the variable
VarNo = 0
'loop used for Trial may be directly assigned to CellStr by increasing Varno by one for each cell
For Each Cell In Rng.Cells
VarNo = VarNo + 1
ReDim Preserve CellStr(1 To 2, 1 To VarNo)
Txt = Cell.Value
CellStr(1, VarNo) = Txt
FntInfo = ""
For i = 1 To Len(Txt)
If Cell.Characters(i, 1).Font.Subscript = True Then
FntInfo = FntInfo & "A"
ElseIf Cell.Characters(i, 1).Font.Superscript = True Then
FntInfo = FntInfo & "B"
Else
FntInfo = FntInfo & "C"
End If
Next i
CellStr(2, VarNo) = FntInfo
Next Cell
'again loop used for Trial may be directly assigned to CellStr from Textboxes in the sheet
For Each shp In ActiveSheet.Shapes
If shp.Type = msoTextBox Then
VarNo = VarNo + 1
ReDim Preserve CellStr(1 To 2, 1 To VarNo)
Txt = shp.TextFrame2.TextRange.Text
CellStr(1, VarNo) = Txt
FntInfo = ""
For i = 1 To Len(Txt)
If shp.TextFrame2.TextRange.Characters(i, 1).Font.Subscript = msoTrue Then
FntInfo = FntInfo & "A"
ElseIf shp.TextFrame2.TextRange.Characters(i, 1).Font.Superscript = msoTrue Then
FntInfo = FntInfo & "B"
Else
FntInfo = FntInfo & "C"
End If
Next i
CellStr(2, VarNo) = FntInfo
End If
Next
'Start of Trial code in excel to be deleted
For i = 1 To UBound(CellStr, 2)
ActiveSheet.Cells(i, 10).Value = CellStr(1, i)
ActiveSheet.Cells(i, 11).Value = CellStr(2, i)
FntInfo = CellStr(2, i)
For j = 1 To Len(FntInfo)
ActiveSheet.Cells(i, 10).Characters(j, 1).Font.Subscript = False
ActiveSheet.Cells(i, 10).Characters(j, 1).Font.Superscript = False
If Mid(FntInfo, j, 1) = "A" Then ActiveSheet.Cells(i, 10).Characters(j, 1).Font.Subscript = True
If Mid(FntInfo, j, 1) = "B" Then ActiveSheet.Cells(i, 10).Characters(j, 1).Font.Superscript = True
Next j
Next
'End of Trial code in excel to be deleted
'Powerpoint placement of data in powerpoint
Dim Pp As PowerPoint.Application
Dim Prs As Presentation
Dim Sld As Slide
Dim Pshp As Shape
Set Pp = CreateObject("Powerpoint.application")
Pp.Visible = True
Set Prs = Pp.Presentations.Open("C:\users\user\desktop\test.pptx")
Set Sld = Prs.Slides(1)
For i = 1 To UBound(CellStr, 2)
Set Pshp = Sld.Shapes(i)
Pshp.TextFrame.TextRange.Text = CellStr(1, i)
FntInfo = CellStr(2, i)
For j = 1 To Len(FntInfo)
Pshp.TextFrame.TextRange.Characters(j, 1).Font.Subscript = False
Pshp.TextFrame.TextRange.Characters(j, 1).Font.Superscript = False
If Mid(FntInfo, j, 1) = "A" Then Pshp.TextFrame.TextRange.Characters(j, 1).Font.Subscript = True
If Mid(FntInfo, j, 1) = "B" Then Pshp.TextFrame.TextRange.Characters(j, 1).Font.Superscript = True
Next j
Next
End Sub
It is suggested to Add reference of Microsoft PowerPoint Object Library and thanks for asking a good question/challenge to achieve something seemingly not possible but logically possible.
Edit: another more simplistic approach (the 1st half of the String variable contains actual string and 2nd half of the variable contains Font Info) with generalized functions is also added below
Sub Sscript2()
Dim Txt As String, Var1 As String, Var2 As String
Dim Addr As String
Var1 = GetVarFont("C6") ' 1st half of the var contains actual string and 2nd half contain font Info
Var2 = GetVarFont("C7") ' 1st half of the var contains actual string and 2nd half contain font Info
'Powerpoint placement of data in powerpoint
Dim Pp As PowerPoint.Application
Dim Prs As Presentation
Dim Sld As Slide
Dim Pshp As Object
Set Pp = CreateObject("Powerpoint.application")
Pp.Visible = True
Set Prs = Pp.Presentations.Open("C:\users\user\desktop\test.pptx")
Set Sld = Prs.Slides(1)
WriteShp Sld.Shapes(8).TextFrame.TextRange, Var1
WriteShp Sld.Shapes(9).TextFrame.TextRange, Var2
End Sub
Sub WriteShp(Ptxt As TextRange, VarX As String)
Dim i As Long
Ptxt.Text = Left(VarX, Len(VarX) / 2)
For i = 1 To Len(VarX) / 2
Ptxt.Characters(i, 1).Font.Subscript = False
Ptxt.Characters(i, 1).Font.Superscript = False
If Mid(VarX, Len(VarX) / 2 + i, 1) = "A" Then Ptxt.Characters(i, 1).Font.Subscript = True
If Mid(VarX, Len(VarX) / 2 + i, 1) = "B" Then Ptxt.Characters(i, 1).Font.Superscript = True
Next
End Sub
Function GetVarFont(Addr As String) As String
Dim Txt As String, i As Long
Txt = Range(Addr).Value
GetVarFont = Txt
For i = 1 To Len(Txt)
If Range(Addr).Characters(i, 1).Font.Subscript = True Then
GetVarFont = GetVarFont & "A"
ElseIf Range(Addr).Characters(i, 1).Font.Superscript = True Then
GetVarFont = GetVarFont & "B"
Else
GetVarFont = GetVarFont & "C"
End If
Next i
End Function