Find Digits between two characters without using Regex - excel

Question

I've been looking for a while for a code that would give me the digits between without using regex (I want my macro to be used by anyone especially non-computer friendly people). This is a small part of a code creating series for a chart dynamically creating the chart etc.
Here is the type of data I am dealing with "C23H120N5O4Cl" so I'd like to save in a variable 23 then in another one 120 the rest should not matter (it could be nothing).
My digits will likely be between single characters (C,H,or else) but I need the numbers after C and H. So at the moment here is my code :
RangeOccupied = Range("C2").End(xlDown).row
For i = 1 To RangeOccupied
If i <> RangeOccupied Then
'Look for digits after C
pos = InStr(1, Cells(i + 1, 2), "C") + 1
pos1 = InStr(pos, Cells(i + 1, 2), "H")
NumC = Mid(Cells(i + 1, 2), pos, pos1 - pos)
'Look for digits after H
pos = InStr(1, Cells(i + 1, 2), "H") + 1
pos1 = InStr(pos, Cells(i + 1, 2), "O")
NumH = Mid(Cells(i + 1, 2), pos, pos1 - pos)
End If
Next
Ideally I'd like the pos1 numbers not to be dependent on a specific character but any character. i.e having pos1=InStr(pos,Cells(i+1,2),"ANY NON-NUMBER CHARACTER").
I do not know if it is possible without using regex.

Answer 1

This function will return an array of the digit strings in a text string
Option Explicit
Function myDigits(str As String) As String()
Dim col As Collection
Dim I As Long, S() As String
I = 0
Set col = New Collection
Do Until I > Len(str)
I = I + 1
If IsNumeric(Mid(str, I, 1)) Then
col.Add Val(Mid(str, I, Len(str)))
I = I + 1
Do Until Not IsNumeric(Mid(str, I, 1))
I = I + 1
Loop
End If
Loop
ReDim S(0 To col.Count - 1)
For I = 1 To col.Count
S(I - 1) = col(I)
Next I
myDigits = S
End Function

Answer 2

Okay, I'm absolutely certain there is a more efficient way of doing this. But I think the following example makes it fairly clear on one way to separate your values.
Option Explicit
Sub test()
Dim testValues() As String
Dim val1 As Long
Dim val2 As Long
testValues = Split("C23H120N5O4Cl,C23O120N5H4Cl,C4H120", ",")
Dim testValue As Variant
For Each testValue In testValues
ExtractValues testValue, val1, val2
Debug.Print "For " & testValue & ": " & val1 & " and " & val2
Next testValue
End Sub
Public Sub ExtractValues(ByVal inString As String, _
ByRef output1 As Long, _
ByRef output2 As Long)
Dim outString1 As String
Dim outString2 As String
Dim stage As String
stage = "Begin"
Dim thisCharacter As String
Dim i As Long
For i = 1 To Len(inString)
thisCharacter = Mid$(inString, i, 1)
Select Case stage
Case "Begin"
If thisCharacter = "C" Then stage = "First Value"
Case "First Value"
If (Asc(thisCharacter) >= Asc("0")) And _
(Asc(thisCharacter) <= Asc("9")) Then
outString1 = outString1 & thisCharacter
Else
'--- if we get here, we're done with this value
output1 = CLng(outString1)
'--- verify the next character is the "H"
If thisCharacter = "H" Then
stage = "Second Value"
Else
stage = "Next Value"
End If
End If
Case "Next Value"
If thisCharacter = "H" Then stage = "Second Value"
Case "Second Value"
If (Asc(thisCharacter) >= Asc("0")) And _
(Asc(thisCharacter) <= Asc("9")) Then
outString2 = outString2 & thisCharacter
Else
'--- if we get here, we're done with this value
output2 = CLng(outString2)
stage = "Finished"
Exit For
End If
End Select
Next i
If Not (stage = "Finished") Then
output2 = CLng(outString2)
End If
End Sub

Answer 3

Here's another method that's more generic and efficient than my first solution. This approach uses a function to extract the number following a given substring -- in this case it's a single letter "C" or "H". The function accounts for the value being at the end of the input value as well.
Option Explicit
Sub test()
Dim testValues() As String
Dim val1 As Long
Dim val2 As Long
testValues = Split("C23H120N5O4Cl,C23O120N5H4Cl,C4H120", ",")
Dim testValue As Variant
For Each testValue In testValues
val1 = NumberAfter(testValue, "C")
val2 = NumberAfter(testValue, "H")
Debug.Print "For " & testValue & ": " & val1 & " and " & val2
Next testValue
End Sub
Private Function NumberAfter(ByVal inString As String, _
ByVal precedingString As String) As Long
Dim outString As String
Dim thisToken As String
Dim foundThisToken As Boolean
foundThisToken = False
Dim i As Long
For i = 1 To Len(inString)
thisToken = Mid$(inString, i, 1)
If thisToken = precedingString Then
foundThisToken = True
ElseIf foundThisToken Then
If thisToken Like "[0-9]" Then
outString = outString & thisToken
Else
Exit For
End If
End If
Next i
NumberAfter = CLng(outString)
End Function

Answer 4

I found this solution from here Extract numbers from chemical formula
Public Function ElementCount(str As String, element As String) As Long
Dim i As Integer
Dim s As String
For i = 1 To 3
s = Mid(str, InStr(str, element) + 1, i)
On Error Resume Next
ElementCount = CLng(s)
On Error GoTo 0
Next i
End Function
Which works but if simple molecules like CH4 are put in it does not work since no number are shown... but I (we) can probably work that out.
Thanks again for all the solutions !
EDIT:
Here is the function I use that I think takes all possible scenarios into account ! Thanks again for your help !
Public Function ElementCount(str As String, element As String) As Long
Dim k As Integer
Dim s As String
For k = 1 To Len(str)
s = Mid(str, InStr(str, element) + 1, k)
On Error Resume Next
ElementCount = CLng(s)
On Error GoTo 0
If InStr(str, element) > 0 And ElementCount = 0 Then
ElementCount = 1
End If
Next k
End Function

Answer 5

EDIT
Changed the function to use and return dictionaries having keys of "C" and "H" paired with their numbers. Included a screenshot below.
Made sure it handles for tricky situations where multiple letters are packed ontop of each other:
Code:
Sub mainLoop()
Dim numbers As Scripting.Dictionary: Set numbers2 = New Scripting.Dictionary
For i = 1 To 5
Set numbers = returnDict(Cells(i, 1).Value)
printout numbers, i
Next
End Sub
Function returnDict(cellValue As String) As Scripting.Dictionary
Dim i As Integer: i = 1
Dim holder As String: holder = ""
Dim letter As String
Set returnStuff = New Scripting.Dictionary
While i < Len(cellValue)
If Mid(cellValue, i, 1) = "C" Or Mid(cellValue, i, 1) = "H" Then
i = i + 1
If IsNumeric(Mid(cellValue, i, 1)) Then
letter = (Mid(cellValue, i - 1, 1))
Do While IsNumeric(Mid(cellValue, i, 1))
holder = holder & Mid(cellValue, i, 1)
i = i + 1
If i > Len(cellValue) Then Exit Do
Loop
returnStuff.Add letter, holder
holder = ""
ElseIf Mid(cellValue, i, 1) <> LCase(Mid(cellValue, i, 1)) Then
returnStuff.Add Mid(cellValue, i - 1, 1), "1"
End If
Else
i = i + 1
End If
Wend
End Function
And heres a quick little function used to print out the contents of the dictionary
Sub printout(dict As Scripting.Dictionary, row As Integer)
Dim i As Integer: i = 2
For Each Key In dict.Keys
Cells(row, i).Value = Key & ": " & dict.Item(Key)
i = i + 1
Next
End Sub

Answer 6

My 2c:
Sub tester()
Dim r, arr, v
arr = Array("C", "Z", "Na", "N", "O", "Cl", "Br", "F")
For Each v In arr
Debug.Print v, ParseCount("C15H12Na2N5O4ClBr", v)
Next v
End Sub
Function ParseCount(f, s)
Const ALL_SYMBOLS As String = "Ac,Al,Am,Sb,Ar,As,At,Ba,Bk,Be,Bi,Bh,Br,Cd,Ca,Cf,Ce,Cs,Cl," & _
"Cr,Co,Cn,Cu,Cm,Ds,Db,Dy,Es,Er,Eu,Fm,Fl,Fr,Gd,Ga,Ge,Au,Hf,Hs,He,Ho,In,Ir,Fe,Kr,La,Lr," & _
"Pb,Li,Lv,Lu,Mg,Mn,Mt,Md,Hg,Mo,Mc,Nd,Ne,Np,Ni,Nh,Nb,No,Og,Os,Pd,Pt,Pu,Po,Pr,Pm,Pa,Ra," & _
"Rn,Re,Rh,Rg,Rb,Ru,Rf,Sm,Sc,Sg,Se,Si,Ag,Na,Sr,Ta,Tc,Te,Ts,Tb,Tl,Th,Tm,Sn,Ti,Xe,Yb,Zn," & _
"Zr,B,C,F,H,I,N,O,P,K,S,W,U,V,Y"
Dim atoms, rv, pos, i As Long
atoms = Split(ALL_SYMBOLS, ",")
rv = 0 'default return value
If IsError(Application.Match(s, atoms, 0)) Then
rv = -1 'not valid atomic symbol
Else
i = 1
pos = InStr(i, f, s, vbBinaryCompare)
If pos > 0 Then
If Len(s) = 2 Then
'should be a true match...
rv = ExtractNumber(f, pos + 2)
ElseIf Len(s) = 1 Then
'check for false positives eg "N" matches on "Na"
Do While pos > 0 And Mid(f, pos + 1, 1) Like "[a-z]"
i = pos + 1
pos = InStr(i, f, s, vbBinaryCompare)
Loop
If pos > 0 Then rv = ExtractNumber(f, pos + 1)
Else
'exotic chemistry...
End If
End If
End If
ParseCount = rv
End Function
'extract consecutive numeric digits from f starting at pos
' *returns 1 if no number present*
Function ExtractNumber(f, pos)
Dim rv, s, i As Long
Do While (pos + i) <= Len(f)
If Not Mid(f, pos + i, 1) Like "#" Then Exit Do
i = i + 1
Loop
ExtractNumber = IIf(i = 0, 1, Mid(f, pos, i))
End Function