vba字符串变量中的上标字母

Question

我正在寻找如何超级/下标VBA字符串变量中的字母/数字。我在excel工作的图表有轴，标题和图表标题，需要s脚本。另外，在文本框中有一个公式：Cpt = Cp0 * e ^（ - ket）其中所有的p，t和0都是下标。整个表达式（-ket）上标有e的嵌入式下标（k＆t之间的e）。最后，所有特殊格式的字符串变量将通过clipboard / gettext复制到PowerPoint变量。

非常感谢任何帮助/指导。

Pat K.

Answer 1

这是解决方法仅限构思，代码可能对您的目的无用，具体取决于数据的来源和目的地，并且可能仅被视为演示。我只在工作表上使用excel单元格和文本框作为目标，并使用PowerPoint文本框作为目标。

简单的方法是，从格式化单元格/文本框中从excel到变量，字体下标，Superscript信息中拾取字符串时，也可以在并行变量（这里是2D数组）中拾取。在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对象库的参考，并感谢您提出一个好的问题/挑战，以实现看似不可能但在逻辑上可能的事情。

编辑：另一种更简单的方法（String变量的前半部分包含实际字符串，变量的下半部分包含Font Info），下面还添加了通用函数

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