CODEWITHSUNDEEP
excelvba
ehdgur
ehdgur

Reputation: 33

Extracting numbers from a string in each cell

I'm trying to write code that extracts X consecutive numbers from text.

For example, if I want to extract 5 consecutive numbers in my text:

I could make it work for texts with only 5 numbers but the problem is if my text contains other consecutive numbers higher than 5.

Sub ExtractNum2()
    Dim Caract() As String
    Dim i As Integer
    Dim j As Integer
    Dim z As Integer
    Dim cont As Integer
    Dim goal As Integer
    Dim Protocolo() As String
    Dim cel As String
    Dim lin As Long

    lin = Range("A1", Range("A1").End(xlDown)).Rows.Count 'Repeat for each line
    For z = 1 To lin
        cel = Cells(z, 1)
        ReDim Caract(Len(cel))
        ReDim Protocolo(Len(cel))
        cont = 0
        For i = 1 To Len(cel)
            Caract(i) = Left(Mid(cel, i), 1)
            If IsNumeric(Caract(i)) Then 'Character check
                cont = cont + 1
                Protocolo(cont) = Caract(i)
                'If Not IsNumeric(Caract(6)) And cont = 5 Then**
                If cont = 5       '
                    Dim msg As String
                    For j = 1 To 5
                        msg = msg & Protocolo(j)
                    Next j
                    Cells(z, 2) = msg 'fills column B
                    msg = ""
                End If
            Else
                cont = 0
            End If
        Next i
    Next z 'end repeat
End Sub

I'm trying to use: 

 If Not IsNumeric(Caract(6)) And cont = 5 Then

But it is not working, my output is: B2: 22222 but I want 11111. What am I missing?

EDIT Sorry i wasnt clear. I want to extract X numbers with 6>x>4 (x=5). I dont want 22222 since it has 8 consecutive numbers and 11111 has 5 in my example.

Upvotes: 0

Views: 336

Answers (2)

JohnyL
JohnyL

Reputation: 7142

UDF:

Function GetNum(cell)
    With CreateObject("VBScript.RegExp")
        .Pattern = "\b(\d{5})\b"
        With .Execute(cell)
            If .Count > 0 Then GetNum = .Item(0).SubMatches(0)
        End With
    End With
End Function

UPDATE:

If you want to return error (say, #N/A) instead of callee's default data type, you could write the following:

Function GetNum(cell)
    With CreateObject("VBScript.RegExp")
        .Pattern = "\b(\d{5})\b"
        With .Execute(cell)
            If .Count > 0 Then
                GetNum = .Item(0).SubMatches(0)
            Else
                GetNum = CVErr(xlErrNA)
            End If
        End With
    End With
End Function

Upvotes: 4

Yeshwant Mudholkar
Yeshwant Mudholkar

Reputation: 107

I tried this with a Cell containing "Yjuj 525211111x5333332s5" to test whether 2 consecutive 5 characters get catch, and it worked great.

Sub Macro_Find_Five()

    Dim str As String
    Dim tmp As String
    Dim cntr As Integer
    Dim result As String

    str = Sheet1.Cells(1, 1).Value

    tmp = ""
    cntr = 1
    col = 2
    result = ""

    'For Loop for tracing each charater
    For i = 1 To Len(str)

        'Ignore first starting character
        If i > 1 Then

            'If the last character matches current character then
            'enter the if condition
            If tmp = Mid(str, i, 1) Then

                'concatenate current character to a result variable 
                result = result + Mid(str, i, 1)

                'increment the counter
                cntr = cntr + 1

            Else

               'if the previous character does not match
               'reset the cntr to 1
                cntr = 1

               'as well initialize the result string to "" (blank)
                result = ""

            End If

        End If

        'if cntr matches 5 i.e. 5 characters traced enter if condition
        If cntr = 5 Then

           'adding to next column the result found 5 characters same
            Sheet1.Cells(1, col).Value = result

            'increment the col (so next time it saves in next column)
            col = col + 1

            'initializing the variables for new search
            cntr = 1
            tmp = ""
            result = ""

        End If

       'stores the last character
        tmp = Mid(str, i, 1)

        'if first character match concatenate.
        If cntr = 1 Then
            result = result + Mid(str, i, 1)
        End If

    Next i

End Sub

Upvotes: 1

Related Questions