Continue to Site

Eng-Tips is the largest engineering community on the Internet

Intelligent Work Forums for Engineering Professionals

  • Congratulations waross on being selected by the Eng-Tips community for having the most helpful posts in the forums last week. Way to Go!

Excel VBA Subscript/Superscript Macro

Status
Not open for further replies.

PEStructural

Structural
Oct 17, 2002
128
All,

I wrote this VB code for automatically subscripting/superscripting text. I find it very cumbersome to subscript and superscript text in excel. The following macro requires that you put brackets [] around anything you want subscripted and tildes {} around anything you want superscripted.

An example would be:

D[col] + x{2} + C[1] + Y[base]

Code:
Sub Super_Sub()
Dim NumSub
Dim NumSuper
Dim SubL
Dim SubR
Dim SuperL
Dim SuperR
Dim CheckSub
Dim CounterSub
Dim CheckSuper
Dim CounterSuper
Dim Cell
'
CheckSub = True
CounterSub = 0
CheckSuper = True
CounterSuper = 0
Cell = ActiveCell
'
NumSub = Len(Cell) - Len(Application.WorksheetFunction.Substitute(Cell, "[", ""))
NumSuper = Len(Cell) - Len(Application.WorksheetFunction.Substitute(Cell, "{", ""))
'
Do
    Do While CounterSub <= 1000
        SubL = Application.WorksheetFunction.Find("[", ActiveCell, 1)
        SubR = Application.WorksheetFunction.Find("]", ActiveCell, 1)
        ActiveCell.Characters(SubL, 1).Delete
        ActiveCell.Characters(SubR - 1, 1).Delete
        ActiveCell.Characters(SubL, SubR - SubL - 1).Font.Subscript = True
        CounterSub = CounterSub + 1
        If CounterSub = NumSub Then
            CheckSub = False
            Exit Do
        End If
    Loop
Loop Until CheckSub = False
'
'
Do
    Do While CounterSuper <= 1000
        SuperL = Application.WorksheetFunction.Find("{", ActiveCell, 1)
        SuperR = Application.WorksheetFunction.Find("}", ActiveCell, 1)
        ActiveCell.Characters(SuperL, 1).Delete
        ActiveCell.Characters(SuperR - 1, 1).Delete
        ActiveCell.Characters(SuperL, SuperR - SuperL - 1).Font.Superscript = True
        CounterSuper = CounterSuper + 1
        If CounterSuper = NumSuper Then
            CheckSuper = False
            Exit Do
        End If
    Loop
Loop Until CheckSuper = False
'
End Sub

Hope this helps.
 
This appears to be a duplicate post - see thread770-138208. Cross-posting is generally discouraged in these forums

Good Luck
johnwm
________________________________________________________
To get the best from these forums read faq731-376 before posting

Steam Engine enthusiasts:
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor