Sub show_fon_nm()
Dim i     As Integer
Dim fr    As String
Dim ed    As Integer
Dim lr    As Long
Dim rng   As Range


  ActiveSheet.Range("b2:b1000").ClearContents
      For Each rng In ActiveSheet.Range("A1:A" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row)
         fr = ""
         ed = 0
         For i = 1 To Len(rng)
                If IsNumeric(Mid(rng, i, 1)) Then
                    fr = fr & Mid(rng, i, 1)
                    ed = ed + 1
                ElseIf ed = 11 And Mid(fr, 1, 1) = 0 And Mid(fr, 2, 1) = 1 Then
                    lr = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
                    Cells(lr + 1, 2).NumberFormat = "@"
                    Cells(lr + 1, 2) = fr
                    fr = ""
                End If
         Next i
                If ed = 11 And Mid(fr, 1, 1) = 0 And Mid(fr, 2, 1) = 1 Then
                    lr = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
                    Cells(lr + 1, 2).NumberFormat = "@"
                    Cells(lr + 1, 2) = fr
                    fr = ""
                End If
      Next rng
End Sub

Option Explicit
Sub splt()
Dim a
Dim x%
Dim m%: m = 1
Dim Phone_array()
 Range("c:c").ClearContents
a = Split(Trim(Range("a1")), " ")

For x = 1 To UBound(a) - LBound(a)
 If Mid(a(x - 1), 1, 2) = "01" And Len(a(x - 1)) = 11 Then
  ReDim Preserve Phone_array(1 To m)
   Phone_array(m) = a(x - 1)
   m = m + 1
   End If
   Next
    Range("c1").Resize(m - 1) = Application.Transpose(Phone_array)
    Range("c1").Resize(m - 1).NumberFormat = "@"
    Erase a: Erase Phone_array
End Sub

الهووم وورك امستر

Sub M_Yasser()
Dim lrw, i%, arr()
Range("B:B").ClearContents
lrw = Range("A:A").Find("*", , , , , 2).Row
ReDim arr(1 To lrw)
    For i = 1 To lrw
       If Left(Cells(i, 1).Text, 2) = "01" Then arr(i) = "'" & Cells(i, 1).Text
    Next i
       Cells(1, 2).Resize(UBound(arr)) = Application.Transpose(arr)
End Sub

Option Explicit
Sub splt()

Dim a
Dim x%
Dim m%: m = 1
Dim r As Byte, t As Byte
Dim s As Byte, v As Byte
Dim verification As Byte
Dim Phone_array()

 Range("c:c").ClearContents
a = Split(Trim(Range("a1")), " ")
For x = 1 To UBound(a) - LBound(a)
    r = -(Mid(a(x - 1), 1, 3) = "010")
    t = -(Mid(a(x - 1), 1, 3) = "011")
    s = -(Mid(a(x - 1), 1, 3) = "012")
    v = -(Mid(a(x - 1), 1, 3) = "015")
    verification = (r + s + t + v) + Len(a(x - 1))
        If verification = 12 Then
         ReDim Preserve Phone_array(1 To m)
         Phone_array(m) = a(x - 1)
         m = m + 1
        End If
Next
On Error GoTo End_Sub
    Range("c1").Resize(m - 1) = Application.Transpose(Phone_array)
    Range("c1").Resize(m - 1).NumberFormat = "@"
End_Sub:
Err.Clear
    Erase a: Erase Phone_array
End Sub

الحل السابق كان للارقام البادئة من 01 فقط
حل اخر على السريع كدا للارقام البادئة ب 010 و 011 و 012 و 015
ودا شرح سريع بروضوا معلش مشغول اوى اليومين دول يأبو الدهب
شوفها وان وقفت معاك حاجه قولى وانا معاك

Sub M_Yasser2()
'Variant ومتغير من النوع Integer اعلان عن متغيرين من النوع
Dim lrw, i%, arr()
'حذف نطاق النتائج
Range("B:B").ClearContents
' تحديد أخر صف ولو مفيش بيانات فى العمود الاول هيجيب خطا بس انا مزاجى كدا
lrw = Range("A:A").Find("*", , , , , 2).Row
'اعادة تعيين ابعاد المصفوفة لتكون من 1 لرقم اخر صف به بيانات
ReDim arr(1 To lrw)
'بدأ حلقة تكرارية من 1 حتى اخر صف به بيانات
    For i = 1 To lrw
    '(010,011,012,015) اختبار شرط وجود الارقام التالية بكل خلية بها الرقم
    'اذا تحقق الشرط يتم تعبئة المصفوفة بالرقم
       If IsNumeric(Application.Match(Left(Cells(i, 1).Text, 3), Array("010", "011", "012", "015"), 0)) Then arr(i) = "'" & Cells(i, 1).Text
    ':D اعادة الحلقة التكرارية مش حلقة افتح الباب
    Next i
    'حتى اخر صف فيه بيانات داخل المصفوفة B1 ادخال بيانات المصفوفة بالخلايا من الخلية
       Cells(1, 2).Resize(UBound(arr)) = Application.Transpose(arr)
    'كدا شطبنا والسلام عليكم
End Sub

Sub M_Yasser3()
Dim lrw, i%
Range("B:B").ClearContents
lrw = Cells(Rows.Count, 1).End(3).Row
    For i = 1 To lrw
    Select Case Left(Cells(i, 1), 3)
        Case "010", "011", "012", "015"
            Cells(i, 2) = "'" & Cells(i, 1).Text
        End Select
    Next i
End Sub

المشاركة الأصلية كتبت بواسطة: محمود ابو الدهب هههههه مصمم يا حبيب الملايين
اكمل المطلوب ثم ارسل
وانته مصمم ليه ان الامر بطلبه ليا نحن في حلقات تعليمية اى المفروض يدخل هنا من لا يعمل ومن يعلم اى يجب ان نراعي ان هناك من لا يعلم ويريد ان يتعلم
وشكرا على الشرح وبارك الله فيك

ولكن في كلا الكودين لم تحقق المطلوب ولم يعطي نتائج
وعليكم السلام ورحمة الله وبركاته
"اوعى تكون بتزعل زى استاذ ياسر دائما احب الهزار في كلامى علشان ارفرش الجو والكمبيوتر كمان "