Macro to extract 10 digit number from cell starting with 501 & 350

[amandeep08]

I have a macro that will fetch 10 digit number starting with 501.

I want to change the same so that it can also fetch the 10 digit number starting with 350.

Below is the code:

Sub Get501s()
Dim R As Long, LastRow As Long, XLXS As String, V As Variant, Arr As Variant
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For R = 1 To LastRow
Arr = Split(Cells(R, "A").Value & " ", 501)
XLXS = ""
For Each V In Arr
If V Like "#######[!0-9]*" Then XLXS = XLXS & ", 501" & Left(V, 7) & ".xlxs"
Next
Cells(R, "A").Value = Mid(XLXS, 3)
Next
End Sub

 

[amandeep08]

Ye

Could this work? I don't know how important is it to attach the file extension to the output, but this extracts all those 10 digits in comma separated format.

Book1.xlsm
	A	B
1	Required Data
2	C:\Users\amandeep.s\Desktop\5-Apr-21\BASF-5021209306.xlsm	5021209306
3	C:\Users\amandeep.s\Desktop\5-Apr-21\Master Order Form for B2B - 3500051959.xlsm	3500051959
4	C:\Users\amandeep.s\Desktop\5-Apr-21\Master Order Form for B2B - 3500051967.xlsm	3500051967
5	C:\Users\amandeep.s\Desktop\5-Apr-21\qualcomn 5021209231 revised.xlsm	5021209231
6	C:\Users\amandeep.s\Desktop\5-Apr-21\Master Order Form for B2B - 3500053967/3500053234.xlsm	3500053967, 3500053234
7	C:\Users\amandeep.s\Desktop\5-Apr-21\qualcomn 5021207542/5021203245 revised.xlsm	5021207542, 5021203245
8	C:\Users\amandeep.s\Desktop\5-Apr-21\master Order form 5021276964 to 5021276986, 5021276990	5021276964, 5021276986, 5021276990
Sheet4

Sub ME1167190_numbers()
    Dim i As Long, j As Long, s, t
   
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        s = ""
        If Cells(i, 1).Value Like "*##########*" Then
            For j = 1 To Len(Cells(i, 1).Value) - 9
                t = ""
                If Mid(Cells(i, 1).Value, j, 10) Like "##########" Then t = Mid(Cells(i, 1).Value, j, 10)
                If t Like "502*" Or t Like "350*" Then s = s & t & ", "
            Next
        End If
        If s <> "" Then Cells(i, "B").Value = Left(s, Len(s) - 2) 'change "B" to "A" to overwrite column A directly.
    Next
End Sub

Could this work? I don't know how important is it to attach the file extension to the output, but this extracts all those 10 digits in comma separated format.

Book1.xlsm
	A	B
1	Required Data
2	C:\Users\amandeep.s\Desktop\5-Apr-21\BASF-5021209306.xlsm	5021209306
3	C:\Users\amandeep.s\Desktop\5-Apr-21\Master Order Form for B2B - 3500051959.xlsm	3500051959
4	C:\Users\amandeep.s\Desktop\5-Apr-21\Master Order Form for B2B - 3500051967.xlsm	3500051967
5	C:\Users\amandeep.s\Desktop\5-Apr-21\qualcomn 5021209231 revised.xlsm	5021209231
6	C:\Users\amandeep.s\Desktop\5-Apr-21\Master Order Form for B2B - 3500053967/3500053234.xlsm	3500053967, 3500053234
7	C:\Users\amandeep.s\Desktop\5-Apr-21\qualcomn 5021207542/5021203245 revised.xlsm	5021207542, 5021203245
8	C:\Users\amandeep.s\Desktop\5-Apr-21\master Order form 5021276964 to 5021276986, 5021276990	5021276964, 5021276986, 5021276990
Sheet4

Sub ME1167190_numbers()
    Dim i As Long, j As Long, s, t
   
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        s = ""
        If Cells(i, 1).Value Like "*##########*" Then
            For j = 1 To Len(Cells(i, 1).Value) - 9
                t = ""
                If Mid(Cells(i, 1).Value, j, 10) Like "##########" Then t = Mid(Cells(i, 1).Value, j, 10)
                If t Like "502*" Or t Like "350*" Then s = s & t & ", "
            Next
        End If
        If s <> "" Then Cells(i, "B").Value = Left(s, Len(s) - 2) 'change "B" to "A" to overwrite column A directly.
    Next
End Sub

In 1st stance, it seems working fine. file extension will manage through a formula.

In 1st stance, it seems working fine. file extension will manage through a formula. There is one issue. Currently, it is populating the result in Column B while my requirement is that it will override Column A

 

[aRandomHelper]

There is one issue. Currently, it is populating the result in Column B while my requirement is that it will override Column A

Read the only line of comment in the code (default in green colour)

 

[amandeep08]

Read the only line of comment in the code (default in green colour)

Thanks Sir.

Its working. Anyways need to test on various scenarios. In case facing any issues, will let u know.

 

[Peter_SSs]

Here is another option that you may wish to consider/test. It requires a lot less looping and is considerably faster (20 to 30 times) by my testing.

Also, I don't know if it would be possible with your data or what result you would want but if it was possible to have, say,
"... master Order form 50212769648625 to 150212769865, 5021276990"
then my code would return only one 10-digit number whereas the earlier code would return three such numbers.

This is also very easy to add additional prefix numbers but would require some modification if those prefixes are not always 3 digits.

Sub Get10Digits()
  Dim RX As Object
  Dim a As Variant, itm As Variant
  Dim i As Long
  Dim s As String
 
  Const sPrefixes As String = "502|350" '<- Edit as required. Assumed always 3 digits
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "(\D)((" & sPrefixes & ")\d{7})(?=\D|$)"
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  For i = 1 To UBound(a)
    s = vbNullString
    For Each itm In RX.Execute(a(i, 1))
      s = s & ", " & Mid(itm, 2)
    Next itm
    a(i, 1) = Mid(s, 3)
  Next i
  Range("B2").Resize(UBound(a)).Value = a '<- Edit to column A to overwrite original data
End Sub