Macro to extract 10 digit number from cell starting with 501

[amandeep08]

Hi All,

I want a Macro that will extract 10 digit number from cell which contains number & alphabets and the number should start from 501. The macro will override that cell with the number and .xlsx

Can someone pl help me

 

[mohadin]

Would you submit few examples of your data, please

 

[amandeep08]

Data	Result
sfwge5012256827	5012256827.xlsx​
dfhfjdsfs5018563057hhlhlll	5018563057.xlsx​
5017456295kbbgghjgjfj	5017456295.xlsx​
fgkkgk5017783572fkfkkj	5017783572.xlsx​
yfkgk5016456785gkkglhl50264974526	5016456785.xlsx​

But the result shown in B Column will override A Column

 

[Rick Rothstein]

Is it possible for the number 501 to appear more than once within a single cell?

 

[amandeep08]

Is it possible for the number 501 to appear more than once within a single cell?

99% cases Number starting with 501 is not possible. If else if it is present and the total digits are 10, in that case, result should be 1st number.xlsx, 2nd number.xlsx
The number should be separated with comma but it will be in a single cell

 

[mohadin]

Try

Sub test()
    Dim a As Variant
    a = Cells(1).CurrentRegion
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "[5][0][1]+\d+"
        For i = 1 To UBound(a)
       a(i, 1) = .Execute(a(i, 1))(0)
        Next
    End With
    Cells(1, 1).Resize(UBound(a)) = a
End Sub

 

[Dave Patton]

not VBA

T202101b.xlsm
	A	B
2	5017456295kbbgghjgjfj	5017456295
3	sfwge5012256827	5012256827
4
2f

Cell Formulas
Range	Formula
B2:B3	B2	=MID(A2,FIND("501",A2,1),10)

 

[amandeep08]

Its not working. Error No. 5 - Invalid procedure call or argument

Try

Sub test()
    Dim a As Variant
    a = Cells(1).CurrentRegion
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "[5][0][1]+\d+"
        For i = 1 To UBound(a)
       a(i, 1) = .Execute(a(i, 1))(0)
        Next
    End With
    Cells(1, 1).Resize(UBound(a)) = a
End Sub

 

[mohadin]

IN othe case

Sub test()
    Dim a As Variant
    a = Cells(1).CurrentRegion
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "[5][0][1]+\d+"
        For i = 1 To UBound(a)
            Set m = .Execute(a(i, 1))
            If m.Count = 1 Then
                a(i, 1) = m(0)
            Else
                For ii = 0 To m.Count - 1
                    tmp = IIf(tmp = "", "", tmp) & "," & m(ii)
                Next
                a(i, 1) = tmp
                tmp = ""
            End If
        Next
    End With
    Cells(1, 1).Resize(UBound(a)) = a
End Sub

 

[mohadin]

OOps
Is it MAC, your OS?