How to sum chemical compounds using Periodic Table of elements (chemistry class)

Question

I have two different tables; one is Periodic Table of elements (PSE) Columns A-C with their respective atomic mass, and another table Column E-F is consistent of compounds which I need to calculate/sum total mass but using first table as a source. So, for instance, compound H2O (water) is total of 18 g/mol (H=1x2, O=16) ... but there are compounds like C6H6Zn or with more numbers in front, and that gives me tough time to understand how to calculate / sum them up. In Column H are the actual values which I need to obtain..

I hope that somebody can help me out somehow, at least any kind of input..

Answer 1

As @Solar Mike pointed out, it would be best to break the problem down into parts – divide and conquer! The code below undertakes 2 distinct steps: 1) split the compound into individual elements and quantities (using the function I found here) and 2) calculate the total weights of all the elements in the compound.

The code assumes that your data is on sheet1 of your workbook, and that the layout is exactly as your image shows. It relies on your list of elements being in column B with their mass in column C (the VLOOKUP() range is from B2:C120 - you may want to adjust it) and that your compounds are listed from cell E2 down. Furthermore, the code requires columns G to (unknown to the right – depends on the complexity of the compound) to be available during code execution, and it will be cleared afterwards.

I’m sure there will be a more elegant solution than this, but it does work on my test data. Please copy all of the code below to a standard module (including the function) and let me know how it goes.

Option Explicit
Sub GetWeights()
Dim LastRow As Long, LastCol As Long, c As Range
Dim i As Integer, j As String, k As Double, weight As Double

'***Part 1 - split the formulas into separate columns
LastRow = Sheet1.Cells(Rows.Count, 5).End(xlUp).Row

With Sheet1.Range("F2:F" & LastRow)
    .FormulaR1C1 = "=SepChem(RC5)"
    .Value = .Value
End With

Application.DisplayAlerts = False
Sheet1.Range("F2:F" & LastRow).Select
    Selection.TextToColumns Destination:=Range("F2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Space:=True, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), _
        TrailingMinusNumbers:=True
Application.DisplayAlerts = True

'***Part 2 - get the weights
LastRow = Sheet1.Cells(Rows.Count, 5).End(xlUp).Row
On Error GoTo Skip
For Each c In Sheet1.Range("F2:F" & LastRow)
If IsEmpty(c.Value) = True Or c.Value = "-" Then GoTo Skip
LastCol = c.End(xlToRight).Column - 1

    For i = c.Column To LastCol Step 2
        
        j = Cells(c.Row, i).Value
        
            k = Application.VLookup(j, Sheet1.Range("B2:C120"), 2, False) _
            * Cells(c.Row, i).Offset(0, 1).Value
            
            weight = weight + k
    
    Next i
    
    c.Value = weight
    weight = 0
Skip:
Next c

With Sheet1
    LastCol = .Range("A1").SpecialCells(xlCellTypeLastCell).Column
End With
Sheet1.Range(Cells(2, 7), Cells(LastRow, LastCol)).ClearContents

End Sub

Public Function SepChem(ByVal s As String) As String
Static RegEx As Object

If RegEx Is Nothing Then
    Set RegEx = CreateObject("VBScript.RegExp")
    RegEx.Global = True
End If

With RegEx
    .Pattern = "([a-zA-Z])(?=[A-Z]|$)"
    s = .Replace(s, "$11")
    .Pattern = "([a-zA-Z])(?=\d)|(\d)(?=[A-Z])"
    SepChem = .Replace(s, "$1$2 ")
End With

End Function