Sub FixFraction()
   Dim doc As Word.Document
   Dim rngUserFrac As Word.Range
   Dim rngNominator As Word.Range
   Dim rngDenominator As Word.Range
   Dim rngSlash As Word.Range
   Dim iPosSlash As Long
   Dim nUserFontSize As Single
   Dim sHeightFactor As String
   Dim nHeightFactor As Single
   Dim nFontSizeFactor As Single
  Application.ScreenUpdating = False
   Set doc = ActiveDocument
   Set rngUserFrac = Selection.Range
   ' Percentage to raise nominator
  ' and tighten spacing to slash.
  nHeightFactor = 0.28
   ' Percentage to reduce fraction font size.
  nFontSizeFactor = 0.6
  iPosSlash = InStr(rngUserFrac.Text, "/")
   ' Font size of current selection.
  nUserFontSize = rngUserFrac.Font.Size
   ' Calculate amount to raise nominator.
  sHeightFactor = CStr(Int(nUserFontSize * nHeightFactor))
   If iPosSlash = 0 Then
   ' Quit if there's no slash in the selection.
     Exit Sub
   Else
     ' Set the ranges to be manipulated.
     Set rngNominator = doc.Range(Start:=rngUserFrac.Start, End:=rngUserFrac.Start + iPosSlash - 1)
     Set rngSlash = doc.Range(Start:=rngUserFrac.Start + iPosSlash - 1, End:=rngUserFrac.Start + iPosSlash)
     Set rngDenominator = doc.Range(Start:=rngUserFrac.Start + iPosSlash, End:=rngUserFrac.End)
   End If
   ' Set font size for the fraction.
  rngNominator.Font.Size = nFontSizeFactor * nUserFontSize
  rngDenominator.Font.Size = nFontSizeFactor * nUserFontSize
     ' Insert the EQ fields.
   ' Move nominator up and pull slash to left.
  doc.Fields.Add Range:=rngNominator, Type:=wdFieldFormula, Text:="\s\up" & sHeightFactor & "(" & rngNominator.Text & ") \d \ba" & sHeightFactor & "()", PreserveFormatting:=False
  doc.Fields.Add Range:=rngDenominator, Type:=wdFieldFormula, Text:=rngDenominator.Text, PreserveFormatting:=False
    ' Slash range now includes nominator, so collapse to
  ' include only the slash, and replace with Symbol
  ' font slash.
   With rngSlash
    .Collapse wdCollapseEnd
    .MoveStart wdCharacter, -1
    .InsertSymbol 164, "Symbol"
   End With

End Sub

Sub FractionWash()
'
    Dim rngStartMarker    As Word.Range
    Set rngStartMarker = Selection.Range
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "<[0-9]{1,}/*>"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        .Execute
        Call FixFraction
        Do While .Found = True
        .Execute
        Call FixFraction
        Loop
      End With
     rngStartMarker.Select
End Sub
