Find and replace superscripts in PowerPoint - replace

Question

Is there a way to customize the code below (for making subscripts and superscripts larger) to search for superscript a , b, c …. and replace them with numbers 1, 2, 3 …in PowerPoint.
Any help would be much appreciated.
Source for the code.
Sub BumpTheSubsAndSupers()
Dim oSl As Slide
Dim oSh As Shape
Dim x As Long
Dim dBumpBy As Double
dBumpBy = 4 ' number of points to bump sub/superscript by
' Check each slide
For Each oSl In ActivePresentation.Slides
' Check each shape on the slide
For Each oSh In oSl.Shapes
' Make sure it's got text
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
With oSh.TextFrame.TextRange
For x = 1 To .Runs.Count
If .Runs(x).Characters.Font.BaselineOffset <> 0 Then
' it's a sub/super; make it four points
' bigger than the text immediately prior:
.Runs(x).Characters.Font.Size = _
.Runs(x - 1).Characters.Font.Size + dBumpBy
End If ' it's a sub/superscript
Next x
End With ' textframe.textrange
End If ' .HasText
End If ' .HasTextFrame
Next oSh '
Next oSl
End Sub

Answer 1

Great question!
I've modified the code to do both (change the size and switch letters to numbers).
You can comment out whichever part you don't want if you like. There are doubtless more efficient ways of doing this (like splitting the array of letters once rather than once for each subscript) but it's all but instant on moderately sized files; the time it'd take to optimize it would probably exceed the time it'd save in use.
If you use letters from other alphabets as sub/superscripts, you'll want to add them to the OrdinalFromLetter function.
Option Explicit
Sub BumpTheSubsAndSupers()
Dim oSl As Slide
Dim oSh As Shape
Dim x As Long
Dim dBumpBy As Double
dBumpBy = 4 ' number of points to bump sub/superscript by
' Check each slide
For Each oSl In ActivePresentation.Slides
' Check each shape on the slide
For Each oSh In oSl.Shapes
' Make sure it's got text
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
With oSh.TextFrame.TextRange
For x = 1 To .Runs.Count
If .Runs(x).Characters.Font.BaselineOffset <> 0 Then
' it's a sub/super; make it four points
' bigger than the text immediately prior:
.Runs(x).Characters.Font.Size = _
.Runs(x - 1).Characters.Font.Size + dBumpBy
.Runs(x).Text = CStr(OrdinalFromLetter(.Runs(x)))
End If ' it's a sub/superscript
Next x
End With ' textframe.textrange
End If ' .HasText
End If ' .HasTextFrame
Next oSh '
Next oSl
End Sub
Function OrdinalFromLetter(sLetter As String) As Long
Dim x As Long
Dim aLetters As Variant
aLetters = Split("A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z", ",")
For x = LBound(aLetters) To UBound(aLetters)
If UCase(sLetter) = aLetters(x) Then
OrdinalFromLetter = x
Exit Function
End If
Next
End Function