Option Explicit 
 
Function GetFormula(ChemFormula As String, Elements As Variant, Optional Multiplier As Long, Optional Atoms As Variant) As String 
     'Returns a simplified formula (each element listed only once) given a traditional chemical formula
    Dim i As Long, First As Long, Last As Long 
    Dim frmla As String, s As String 
     
    If Multiplier = 0 Then Multiplier = 1 
     
    On Error Resume Next 
    s = Elements.Address 
    On Error GoTo 0 
    If s = "" Then 'Test whether function called from worksheet or VBA
        First = LBound(Elements) 
        Last = UBound(Elements) 
    Else 
        First = 1 
        Last = Elements.Cells.Count 
    End If 
     
    If IsMissing(Atoms) Then ReDim Atoms(First To Last) 
     
    Atoms = GetElements(ChemFormula, Elements, Multiplier, Atoms) 
    For i = LBound(Atoms) To UBound(Atoms) 
         'If Atoms(i) = 1 Then frmla = frmla & Elements(i) & Atoms(i) & " "      'Show a 1 after elements with just one atom in ChemFormula
        If Atoms(i) = 1 Then frmla = frmla & Elements(i) & " " 'Don't show a 1 after elements with just one atom in ChemFormula
        If Atoms(i) > 1 Then frmla = frmla & Elements(i) & Atoms(i) & " " 
    Next 
    GetFormula = frmla 
End Function 
 
Function GetElements(ChemFormula As String, Elements As Variant, Optional Multiplier As Long, Optional Atoms As Variant) As Variant 
    Dim RgExp As Object, MatchCollection As Object, oMatch As Object, RegSub As Object 
    Dim First As Long, i As Long, iLeft(1 To 7) As Long, iRight(1 To 7) As Long, _ 
    j As Long, Last As Long, LenFrmla As Long, n As Long, nest As Long 
    Dim frmla As String, s As String, sTemp As String 
     
    If Multiplier = 0 Then Multiplier = 1 
     
    LenFrmla = Len(ChemFormula) 
    For i = 1 To Len(ChemFormula) 
        If Mid(ChemFormula, i, 1) = "(" Then 
            nest = nest + 1 
            iLeft(nest) = i 
        End If 
        If Mid(ChemFormula, i, 1) = ")" Then 
            iRight(nest) = i 
            nest = nest - 1 
            If nest = 0 Then 
                If IsNumeric(Mid(ChemFormula, iRight(1) + 1, 1)) Then 
                    n = Multiplier * Val(Mid(ChemFormula, iRight(1) + 1)) 'Multiplier for radical inside parentheses
                    j = Len(n & "") 
                Else 
                    n = 1 
                End If 
                frmla = GetFormula(Mid(ChemFormula, iLeft(1) + 1, iRight(1) - iLeft(1) - 1), Elements, n, Atoms) 
                ChemFormula = Left(ChemFormula, iLeft(1) - 1) & Mid(ChemFormula, iRight(1) + 1 + j) 
                i = iLeft(1) - 1 
                LenFrmla = Len(ChemFormula) 
            End If 
        End If 
    Next 
     
    On Error Resume Next 
    sTemp = Elements.Address 
    On Error GoTo 0 
    If sTemp = "" Then 'Test whether function called from worksheet or VBA
        First = LBound(Elements) 
        Last = UBound(Elements) 
    Else 
        First = 1 
        Last = Elements.Cells.Count 
    End If 
     
    If IsMissing(Atoms) Then ReDim Atoms(First To Last) 
     
    Set RgExp = CreateObject("VBScript.RegExp") 
    For i = First To Last 
        If Len(Elements(i)) > 1 Then s = s & Elements(i) & "|" 
    Next 
    For i = First To Last 
        If Len(Elements(i)) = 1 Then s = s & Elements(i) & "|" 
    Next 
    RgExp.Pattern = "(" & Mid(s, 1, Len(s) - 1) & ")(\d+|)" 
    RgExp.Global = True 
     
    Set MatchCollection = RgExp.Execute(ChemFormula) 
    For Each oMatch In MatchCollection 
        Set RegSub = oMatch.submatches 
        i = Application.Match(RegSub(0), Elements, 0) + First - 1 
        If RegSub(1) = "" Then 
            Atoms(i) = Atoms(i) + Multiplier 
        Else 
            Atoms(i) = Atoms(i) + CLng(RegSub(1)) * Multiplier 
        End If 
    Next 
     
    GetElements = Atoms 
    Set oMatch = Nothing 
    Set MatchCollection = Nothing 
    Set RgExp = Nothing 
    Set RegSub = Nothing 
End Function 
 
Sub FormulaSubscripting() 
    Dim cel As Range 
    Dim RgExp As Object, oMatch As Object, oMatches As Object 
    Dim i As Long, n As Long 
    Set RgExp = CreateObject("VBScript.RegExp") 
    RgExp.Pattern = "\d+" 
    RgExp.Global = True 
    For Each cel In Selection 
        If cel <> "" Then 
            n = 1 'Single cell array formulas can be converted, but not multi-cell formulas
            If cel.HasArray Then n = cel.CurrentArray.Cells.Count 
            If n = 1 Then 
                i = 0 
                cel.Formula = cel.Value 
                Set oMatches = RgExp.Execute(cel) 
                If oMatches.Count > 0 Then 
                    For Each oMatch In oMatches 
                        i = InStr(i + 1, cel, oMatch) 
                        cel.Characters(i, Len(oMatch)).Font.Subscript = True 
                    Next 
                End If 
            End If 
        End If 
    Next 
    Set oMatch = Nothing 
    Set oMatches = Nothing 
    Set RgExp = Nothing 
End Sub