Extract numbers from chemical formula - including multiple elements within parentheses

Question

I have a list of thousands of chemical formulae in a spreadsheet, and I want to count the number of times each chemical element appears in each chemical formula. Some examples are given here:

1. CH₃NO₃
2. CSe₂
3. C₂Cl₂
4. C₂Cl₂O₂
5. C₄H₆COOH
6. (C₆H₅)₂P(CH₂)₆P(C₆H₅)₂

I have found some code by @PEH (Extract numbers from chemical formula) that works really well. However, it becomes very slow when extracting thousands of values. So, I have created an array version (see below), and managed to speed things up with some input from another user (How to speed up extracting numbers from chemical formula). It works and really speeds things up. However, I also need it to find multiple elements within parentheses (the code below does not currently work for chemical formula no. 6 above - should be 30 C, 32 H, 2 P). I am hoping someone might be able to suggest a way to build on the regex approach below to achieve this. There was some code in the original ChemRegex to do this (https://stackoverflow.com/a/46091904/17194644) but I could not make it work in the sub - it gives this error if I try to include it in the sub:

Private RegEx As RegExp

Function CountElements(ChemFormulaRange As Variant, ElementRange As Variant) As Variant

'define variables
Dim RetValRange() As Long
Dim RetVal As Long
Dim ChemFormula As String
Dim npoints As Long
Dim i As Long
Dim mpoints As Long
Dim j As Long

' Connvert input ranges to variant arrays
If TypeName(ChemFormulaRange) = "Range" Then ChemFormulaRange = ChemFormulaRange.Value
If TypeName(ElementRange) = "Range" Then ElementRange = ElementRange.Value

'parameter
npoints = UBound(ChemFormulaRange, 1) - LBound(ChemFormulaRange, 1) + 1
mpoints = UBound(ElementRange, 2) - LBound(ElementRange, 2) + 1

'dimension array
ReDim RetValRange(1 To npoints, 1 To mpoints)

If RegEx Is Nothing Then
    Set RegEx = New RegExp
    ' apply the properties
End If

'calculate all values
For j = 1 To mpoints
    Element = ElementRange(1, j)
        For i = 1 To npoints
        RetVal = 0
        ChemFormula = ChemFormulaRange(i, 1)
            Call ChemRegex(ChemFormula, Element, RetVal, RegEx)
        RetValRange(i, j) = RetVal
        Next i
Next j

'output answer
CountElements = RetValRange

End Function
Private Sub ChemRegex(ChemFormula, Element, RetVal, RegEx)
    
'ChemRegex created by PEH (CC BY-SA 4.0) https://stackoverflow.com/a/46091904/17194644
    
    With RegEx
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
    End With
    
    'first pattern matches every element once
    RegEx.Pattern = "([A][cglmrstu]|[B][aehikr]?|[C][adeflmnorsu]?|[D][bsy]|[E][rsu]|[F][elmr]?|[G][ade]|[H][efgos]?|[I][nr]?|[K][r]?|[L][airuv]|[M][cdgnot]|[N][abdehiop]?|[O][gs]?|[P][abdmortu]?|[R][abefghnu]|[S][bcegimnr]?|[T][abcehilms]|[U]|[V]|[W]|[X][e]|[Y][b]?|[Z][nr])([0-9]*)"
    
    Dim Matches As MatchCollection
    Set Matches = RegEx.Execute(ChemFormula)
    
    Dim m As Match
    For Each m In Matches
        If m.SubMatches(0) = Element Then
            RetVal = RetVal + IIf(Not m.SubMatches(1) = vbNullString, m.SubMatches(1), 1)
        End If
    Next m
    
End Sub

Answer 1

Looks like you adapted your code to reuse the RegExp object as I suggested last time, and indeed I'd expect that to improve performance considerably. However I should have explained better how to implement but see the example below.

In the example I also took your second RegExp pattern but reworked the rest. This example seems to work for me with your sample data but that's all I've tested!

Option Explicit    
Private regEx As RegExp
Private regEx2 As RegExp

Sub Test()
' formulas in A2:A7 and elements in B1:H1 (see OP's screenshot), return results in B2:H7
    Range("B2:H7").Value = CountElements(Range("A2:A7").Value, Range("B1:H1"))
End Sub

Function CountElements(ChemFormulaRange As Variant, ElementRange As Variant) As Variant
Dim RetValRange() As Long
Dim RetVal As Long
Dim ChemFormula As String
Dim i As Long, j As Long
Dim mpoints As Long, npoints As Long
Dim Element As String

    If regEx Is Nothing Then
        Set regEx = New RegExp
        With regEx
            .Global = True
            '.MultiLine = True ' ? only if working with multilines
            .IgnoreCase = False
            
            'first pattern matches every element once
            .Pattern = "([A][cglmrstu]|[B][aehikr]?|[C][adeflmnorsu]?|[D][bsy]|[E][rsu]|[F][elmr]?|[G][ade]|[H][efgos]?|[I][nr]?|[K][r]?|[L][airuv]|[M][cdgnot]|[N][abdehiop]?|[O][gs]?|[P][abdmortu]?|[R][abefghnu]|[S][bcegimnr]?|[T][abcehilms]|[U]|[V]|[W]|[X][e]|[Y][b]?|[Z][nr])([0-9]*)"
        End With
        
        Set regEx2 = New RegExp
        With regEx2
            .Global = True
            '.MultiLine = True ?
            .IgnoreCase = False

            'second patternd finds parenthesis and multiplies elements within
            .Pattern = "(\((.+?)\)([0-9])+)+?"
        End With
    End If


    ' Convert input ranges to variant arrays
    If TypeName(ChemFormulaRange) = "Range" Then ChemFormulaRange = ChemFormulaRange.Value
    If TypeName(ElementRange) = "Range" Then ElementRange = ElementRange.Value

    'parameter
    npoints = UBound(ChemFormulaRange, 1) - LBound(ChemFormulaRange, 1) + 1
    mpoints = UBound(ElementRange, 2) - LBound(ElementRange, 2) + 1

    'dimension arrays
    ReDim RetValRange(1 To npoints, 1 To mpoints)

    'calculate all values
    For i = 1 To npoints
        ChemFormula = ChemFormulaRange(i, 1)
        For j = 1 To mpoints
            RetVal = 0
            Element = ElementRange(1, j)
            Call ChemRegex(ChemFormula, Element, RetVal)
            RetValRange(i, j) = RetVal
        Next
    Next

    'output answer
    CountElements = RetValRange
    
   ' Set regEx = Nothing: Set regEx2 = Nothing

End Function

Private Sub ChemRegex(ChemFormula, Element, RetVal)
Dim Matches As MatchCollection, Matches2 As MatchCollection
Dim m As Match, m2 As Match
    
    Set Matches = regEx.Execute(ChemFormula)
    For Each m In Matches
        If m.SubMatches(0) = Element Then
            RetVal = RetVal + IIf(Not m.SubMatches(1) = vbNullString, m.SubMatches(1), 1)
        End If
    Next m

    If InStr(1, ChemFormula, "(") Then ' if the formula includes elements within parentheses
        Set Matches2 = regEx2.Execute(ChemFormula)
        For Each m2 In Matches2
            Set Matches = regEx.Execute(m2.Value)
            For Each m In Matches
                If m.SubMatches(0) = Element Then
                    If m.SubMatches(1) = vbNullString Then
                        RetVal = RetVal + m2.SubMatches(2) - 1
                    Else
                        RetVal = RetVal + m.SubMatches(1) * (m2.SubMatches(2) - 1)
                    End If
                End If
            Next
        Next m2
    End If

End Sub

This could certainly be improved a little more by testing all the elements in one RegExp exectution as suggested by CDP1802, but I'll leave that to you!

Answer 2

You might get a performance improvement from extracting all the elements in one regex execution rather that for only one element at a time.

Option Explicit

Sub Demo()

    Dim lastrow As Long, lastcol As Long
    Dim c As Long, r As Long, d As Object
    Dim f As String, el As String, ar
    Set d = CreateObject("Scripting.Dictionary")
    
    With Sheet1
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        ar = .Cells(1, 1).Resize(lastrow, lastcol)
        
        For r = 2 To lastrow
            f = ar(r, 1)
            Call parse(d, f)
            For c = 2 To lastcol
               el = ar(1, c)
               If d.exists(el) Then
                   ar(r, c) = d(el)
               End If
            Next
            d.RemoveAll
        Next
        .Cells(1, 1).Resize(lastrow, lastcol) = ar
    End With
    
    MsgBox "Done"
    
End Sub

Sub parse(ByRef dict, s As String)
  
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .Global = False
        .Pattern = "[(]([^)]+)[)](\d+)"
    End With
    
    ' expand bracket into multiple entries
    Dim m, matches, sm, n As Long, el As String
    Do While regex.test(s)
        Set m = regex.Execute(s)
        For n = 1 To m(0).submatches(1)
            s = s & " " & m(0).submatches(0)
        Next
        s = regex.Replace(s, "")
    Loop
    
    ' count elements
    regex.Pattern = "(" & Symbols & ")([0-9]*)"
    regex.Global = True
    If regex.test(s) Then
        Set matches = regex.Execute(s)
        For Each m In matches
            el = m.submatches(0)
            n = Val(m.submatches(1))
            If n = 0 Then n = 1
            dict(el) = dict(el) + n
        Next
    End If
    
End Sub

Function Symbols() As String

   Symbols = "A[cglmrstu]|" & _
        "B[aehikr]?|" & _
        "C[adeflmnorsu]?|" & _
        "D[bsy]|" & _
        "E[rsu]|" & _
        "F[elmr]?|" & _
        "G[ade]|" & _
        "H[efgos]?|" & _
        "I[nr]?|" & _
        "K[r]?|" & _
        "L[airuv]|" & _
        "M[cdgnot]|" & _
        "N[abdehiop]?|" & _
        "O[gs]?|" & _
        "P[abdmortu]?|" & _
        "R[abefghnu]|" & _
        "S[bcegimnr]?|" & _
        "T[abcehilms]|" & _
        "[UVW]|" & _
        "X[e]|" & _
        "Y[b]?|" & _
        "Z[nr]"

End Function