Find Digits between two characters without using Regex

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

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 3

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 4

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 5

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 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