VBA to insert before and after superscript and subscript in MSWord

Question

I am trying to create VBA to insert before and after Supercript and subscript. My code is below.

Public Sub MySubscriptSuperscript() 
Dim myRange As Word.Range, myChr 
For Each myRange In ActiveDocument.StoryRanges  
Do     
     For Each myChr In myRange.Characters 
     If myChr.Font.Superscript = True Then
        myChr.Font.Superscript = False
        myChr.InsertBefore "<sup>"
        myChr.InsertAfter "</sup>"
    End If  

    If myChr.Font.Subscript = True Then
        myChr.Font.Subscript = False
        myChr.InsertBefore "<sub>"
        myChr.InsertAfter "</sub>"
    End If
Next
Set myRange = myRange.NextStoryRange
Loop Until myRange Is Nothing   
Next 
End Sub

This code is working good for each character of superscript and subscript.

But, I am looking for VBA which insert tags before and after complete superscript/subscript word/letters.

Example

C _{1 2} H _{2 2} O _{1 1} and x ^{2 3} + y ^{3 9 7} + x ^{6 7}

Above VBA is giving following Output

C<sub>1</sub><sub>2</sub>H<sub>2</sub><sub>2</sub>O<sub>1</sub><sub>1</sub><sub> </sub><sub> </sub> and x<sup>2</sup><sup>3</sup> + y<sup>3</sup><sup>9</sup><sup>7</sup> + x<sup>6</sup><sup>7</sup>

But I am looking for this output

C<sub>12</sub>H<sub>22</sub>O<sub>11</sub> and x<sup>23</sup> + y<sup>397</sup> + x<sup>67</sup>

Pls guide, how this can be achieved.

Answer 1

I would be tempted to go for easiest way to get the end result - at the end, simply do a replace of </sub><sub> and </sup><sup> with an empty string "" .

But then, I am lazy this way...

Edit - just an idea: wouldn't it be faster to do the whole thing with replace? You wouldn't have to check every character. Here is what Word does record for the replacement, it would need a bit of polishing:

    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Superscript = False
        .Subscript = False
    End With
    With Selection.Find
        .Text = "^?"
        .Replacement.Text = "<sup>^&</sup>"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

So, at the end, you would run search&replace 4 times:

• replace superscript
• delete the closing and opening tags for superscript
• replace subscript
• delete the closing and opening tags for subscript

Answer 2

Try:

Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Text = ""
    .Wrap = wdFindContinue
    .Font.Subscript = True
    .Replacement.Text = "<sub>^&<\sub>"
    .Execute Replace:=wdReplaceAll
    .Font.Superscript = True
    .Replacement.Text = "<sup>^&<\sup>"
    .Execute Replace:=wdReplaceAll
  End With
End With
Application.ScreenUpdating = True
End Sub

It's not apparent why you'd be looping through all storyranges, as such content would ordinarily only be in the document body. That said, it's easy enough to modify the code to work with all storyranges.