Search numbers in a String VBA

Question

I'm trying to search for number-type characters in consecutive positions (at least 3) in a string. For example, if I have this string:

"Lorem ipsum dolor sit amet, consectetur adipiscing elit. Nulla purus dui, lobortis non 54leo non, feugiat venenatis urna. Morbi lobortis ligula tincidunt 1844763, accumsan massa vel, placerat libero. In a nisl in leo lacinia 243 ullamcorper eget id tortor. Cras vehicula malesuada luctus. Donec egestas non arcu in blandit. Donec eu lacinia ipsum, et consequat mi. Nulla 46626 laoreet viverra purus fringilla pellentesque. Mauris sit amet pulvinar velit, at dignissim lacus. Maecenas non sollicitudin ex. Fusce luctus enim eff43icitur aliquet finibus. Nam ac 1fermentum lacus."

I want my VBA script to return this:

1844763
243
46626

This is the script I'm currently working with:

                start = 1
                Do
                    If IsNumeric(Mid(Sheets("Sheet1").Cells(x, 1), start, 1)) Then
                        If start = Len(Sheets("Sheet1").Cells(x, 1)) Then
                            Exit Do
                        End If
                        If IsNumeric(Mid(Sheets("Sheet1").Cells(x, 1), start + 1, 1)) Then
                            If start + 1 = Len(Sheets("Sheet1").Cells(x, 1)) Then
                                Exit Do
                            End If
                            If IsNumeric(Mid(Sheets("Sheet1").Cells(x, 1), start + 2, 1)) Then
                                Sheets("Sheet1").Cells(x, 2).Interior.Color = RGB(255, 0, 0)
                                Sheets("Sheet1").Cells(x, 2) = Sheets("Sheet1").Cells(x, 2) & Mid(Sheets("Sheet1").Cells(x, 1), start, 3)
                                start = start + 3
                                While IsNumeric(Mid(Sheets("Sheet1").Cells(x, 1), start, 1))
                                    Sheets("Sheet1").Cells(x, 2) = Sheets("Sheet1").Cells(x, 2) & Mid(Sheets("Sheet1").Cells(x, 1), start, 1)
                                    start = start + 1
                                Wend
                                Sheets("Sheet1").Cells(x, 2) = Sheets("Sheet1").Cells(x, 2) & vbCrLf
                            End If
                        End If
                    End If
                   If Not IsNumeric(Mid(Sheets("Sheet1").Cells(x, 1), start, 1)) Then
                        start = start + 1
                    End If
                Loop While inicio < Len(Sheets("Comments").Cells(x, 1))

The script works just fine with small strings (10-20 characters). Things get messy when dealing with strings like the one above (my computer slows down significantly and excel becomes non responsive forever). Do you have any idea on how to optimize this code?

Thank you!

^ Here is a link to regex in VBA. Its definitely what you want to use for this. https://stackoverflow.com/questions/22542834/how-to-use-regular-expressions-regex-in-microsoft-excel-both-in-cell-and-loops — Warcupine, Sep 26 '19 at 13:07
@Warcupine will most definitely look into regex for future work. Thank you — g_anayaguerrero, Sep 26 '19 at 18:44

score 5 · Answer 1 · answered Sep 26 '19 at 13:23

Here is a regular expressions solution. The output is put in separate cells, but could be returned as a string etc. Perhaps turn it into a UDF?

Sub Regex2()

Dim oMatches As Object, i As Long, vOut

With CreateObject("VBScript.RegExp")
    .Global = True
    .Pattern = "\d{3,}"
    If .Test(Range("A1")) Then
        Set oMatches = .Execute(Range("A1"))
        ReDim vOut(0 To oMatches.Count - 1)
        For i = 0 To oMatches.Count - 1
            vOut(i) = oMatches(i).Value
        Next i
        Range("B1").Resize(i) = WorksheetFunction.Transpose(vOut)
    End If
End With

End Sub

score 0 · Answer 2 · answered Sep 26 '19 at 13:35

You could try:

Option Explicit

Sub test()

    Dim arr As Variant
    Dim i As Long, y As Long, Counter As Long
    Dim str As String

    str = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Nulla purus dui, lobortis non 54leo non, feugiat venenatis urna." & _
            "Morbi lobortis ligula tincidunt 1844763, accumsan massa vel, placerat libero. In a nisl in leo lacinia 243 ullamcorper eget id tortor." & _
            "Cras vehicula malesuada luctus. Donec egestas non arcu in blandit. Donec eu lacinia ipsum, et consequat mi." & _
            "Nulla 46626 laoreet viverra purus fringilla pellentesque. Mauris sit amet pulvinar velit, at dignissim lacus." & _
            "Maecenas non sollicitudin ex. Fusce luctus enim eff43icitur aliquet finibus. Nam ac 1fermentum lacus."

    arr = Split(str, " ")

    For i = LBound(arr) To UBound(arr)

        Counter = 0

        For y = 1 To Len(Trim(arr(i)))

            If IsNumeric(Mid(Trim(arr(i)), y, 1)) Then

                Counter = Counter + 1

            End If

            If Counter >= 3 Then

                Debug.Print Replace(Trim(arr(i)), ",", "")
                Exit For

            End If

        Next y

    Next i

End Sub

score 0 · Accepted Answer · answered Sep 26 '19 at 14:13

although not a bulletproof one, you could use this function:

Function GetNumbersWithAtLeastThreeDigits(ByVal s As String) As String
    Dim charsToRemove As String
    charsToRemove = "abcdefghijklmnopqrstuvwxyz.," 

    s = LCase(s)
    Dim i As Long
    For i = 1 To Len(charsToRemove)
        s = Replace(s, Mid(charsToRemove, i, 1), "")
    Next

    Dim res As String
    Dim v As Variant
    For Each v In Split(WorksheetFunction.Trim(s), " ")
        If CLng(Val(v)) > 99 Then res = res & Val(v) & vbNewLine
    Next

    GetNumbersWithAtLeastThreeDigits = res
End Function

which will return a string with all found numbers divided by a newline character

Worked like a charm thank you! Had to do minor rework to include it in my script plus apparently CLng wasn't big enough so I had to use CDbl. — g_anayaguerrero, Sep 26 '19 at 18:39

Search numbers in a String VBA

3 Answers3