Subscript Superscript Macro VBA for Excel 1

[alvarocanivell]

thread770-138208

In line with the other piece of great code, I made a modification that alows you to use ^ for super, _ for sub, and optionally also use parenthesis () to mark start and end of sub or sup.

I hope latex former users, or matlab ones will love this !

Sub SuperscriptSubscriptSelection2()
' Taken from

http://www.eng-tips.com/viewthread.cfm?qid=138208

as base source code,
' Then modified it to act over a selected range of cells. BAsically reqacts against ^ and _ and
' it is also possible to optionally use parenthesis () as well, with either ^ or _

Dim NumSub
Dim NumSup
Dim SubL
Dim SubR
Dim SupL
Dim SupR
Dim CheckSub
Dim CounterSub
Dim CheckSup
Dim CounterSup
Dim Cell As Range

'
CheckSub = True
CounterSub = 0
CheckSup = True
CounterSup = 0


' Looping through all the cells in the active range
For Each Cell In Selection
Cell.Activate

' We count the number of super scripts and subscripts for each cell
NumSub = Len(Cell) - Len(Application.WorksheetFunction.Substitute(Cell, "_", ""))
NumSup = Len(Cell) - Len(Application.WorksheetFunction.Substitute(Cell, "^", ""))

' We arrange first the superscripts
If Len(Cell) = 0 Then Exit Sub
If IsError(Application.Find("^", Cell, 1)) = False Then
Do
Do While CounterSup <= 1000
SupStart = Application.Find("^", Cell, 1)
RestOfString = Mid(Cell, SupStart, 2)
If (IsError(Application.Find("(", RestOfString, 1)) = False) Then
RestOfString = Mid(Cell, SupStart, Len(Cell) - SupStart + 1)
If (IsError(Application.Find(")", RestOfString, 1)) = False) Then
SupL = SupStart - 1 + Application.Find("(", RestOfString, 1)
SupR = SupStart - 1 + Application.Find(")", RestOfString, 1)
Cell.Characters(SupL, SupR - SupL).Font.Superscript = True
Cell.Characters(SupR, 1).Delete
Cell.Characters(SupL, 1).Delete
Cell.Characters(SupStart, 1).Delete
End If
Else
SupL = SupStart
SupR = SupStart + 2
Cell.Characters(SupStart, 1).Delete
Cell.Characters(SupL, SupR - SupL - 1).Font.Superscript = True
End If


CounterSup = CounterSup + 1
If CounterSup >= NumSup Then
CheckSup = False
Exit Do
End If
Loop
Loop Until CheckSup = False
End If
'

' We arrange second the subscripts
If Len(Cell) = 0 Then Exit Sub
If IsError(Application.Find("_", Cell, 1)) = False Then
Do
Do While CounterSub <= 1000
SubStart = Application.Find("_", Cell, 1)
RestOfString = Mid(Cell, SubStart, 2)
If (IsError(Application.Find("(", RestOfString, 1)) = False) Then
RestOfString = Mid(Cell, SubStart, Len(Cell) - SubStart + 1)
If (IsError(Application.Find(")", RestOfString, 1)) = False) Then
SubL = SubStart - 1 + Application.Find("(", RestOfString, 1)
SubR = SubStart - 1 + Application.Find(")", RestOfString, 1)
Cell.Characters(SubL, SubR - SubL).Font.Subscript = True
Cell.Characters(SubR, 1).Delete
Cell.Characters(SubL, 1).Delete
Cell.Characters(SubStart, 1).Delete
End If
Else
SubL = SubStart
SubR = SubStart + 2
Cell.Characters(SubStart, 1).Delete
Cell.Characters(SubL, SubR - SubL - 1).Font.Subscript = True
End If


CounterSub = CounterSub + 1
If CounterSub >= NumSub Then
CheckSub = False
Exit Do
End If
Loop
Loop Until CheckSub = False
End If

Next Cell

End Sub