Это Временное решение Идея только и код может быть бесполезен для ваших целей в зависимости от источника и назначения данных и может рассматриваться как только демонстрационная версия.я использовал только ячейки Excel и текстовые поля на листе в качестве места назначения и использовал текстовые поля PowerPoint в качестве цели.
Простой подход заключается в том, что при подборе String из отформатированных ячеек / текстовых полей из Excel в переменную, Font Subscript, Superscript, информация также должна собираться в параллельной переменной (здесь в 2DArray).Та же информация о шрифте может использоваться при записи в PowerPoint. Демонстрационная идея должна быть изменена / преобразована в соответствии с вашими потребностями.
Демонстрационный снимок экрана 
Демонстрационный код
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
Предлагается добавить ссылку на библиотеку объектов Microsoft PowerPoint и благодарим за то, что задали хороший вопрос / задачу для достижения чего-то, казалось бы, невозможного, но логически возможного.
Редактировать: еще один более упрощенный подход (1-я половина переменной String содержит фактическую строку, а 2-я половина переменной содержит информацию о шрифте) с обобщенными функциями также добавлена ниже
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