Hücrede karışık verilerin arasından telefon numarasını çekmek

[pNouma]

Merhaba,
Ekli excel sayfasındaki hücrelerde isim soy isim ve telefon numaraları karışık yazılmış durumda;

ekli linkteki tabloda görüleceği üzeri farklı hücrelerin içeriğinde telefon numarası hep farklı formatlarda yazılmış durumda;
buradan isim-soy isim ve telefon numaralarını makro ile nasıl ayırabiliriz.

https://dosya.co/atandgbx3jkm/Kitap1.xlsx.html

yardımlarınız için şimdiden teşekkürler,
iyi çalışmalar.

 

[Biolightant]

Merhaba,

Sub AyirVeFormatla()
    
    Dim i As Long
    i = 2 ' Başlangıç hücresinin satır numarası
    
    Dim veri As String
    Dim isim As String
    Dim telefon As String
    
    ' B2 hücresinden başlayarak en son dolu hücreye kadar döngü
    Do While Cells(i, 2).Value <> ""
        veri = Cells(i, 2).Value
        veri = Replace(veri, "Tel:", "") ' Genel yapılan hata düzeltme
        
        ' İsim ve telefon numarasını ayırmak için
        isim = ""
        telefon = ""
        
        Dim c As Integer
        For c = 1 To Len(veri)
            Dim karakter As String
            karakter = Mid(veri, c, 1)
            
            If karakter Like "[A-Za-zçğıöşüÇĞİÖŞÜ ]" Then ' Türkçe karakterler dahil harfler ve ara boşlukları yakala
                isim = isim & karakter
            ElseIf karakter Like "[0-9]" Then ' sadece rakamları yakala
                telefon = telefon & karakter
            End If
        Next c
        
        ' Telefon verisinin ilk karakteri 0 ise bunu sil
        If Left(telefon, 1) = "0" Then
            telefon = Mid(telefon, 2)
        End If
        
        ' Telefon numarasını formatla
        If Len(telefon) <= 10 Then ' tel numarası 10 karakter ve hatalı olarak 10 karakterden küçükse
            telefon = "(" & Left(telefon, 3) & ") " & Mid(telefon, 4, 3) & " " & Mid(telefon, 7, 2) & " " & Mid(telefon, 9, 2)
        ElseIf Len(telefon) > 10 Then ' tel numara hatalı 10 karakterden fazla
            telefon = "(" & Left(telefon, 3) & ") " & Mid(telefon, 4, 3) & " " & Mid(telefon, 7, 2) & " " & Mid(telefon, 9, 2) & " " & Mid(telefon, 11)
        End If
        
        ' C ve D sütunlarına veri yaz
        Cells(i, 3).Value = Trim(isim)
        Cells(i, 4).Value = telefon
        
        i = i + 1 ' Bir sonraki satıra geç
    Loop
End Sub

 

[pNouma]

Merhaba,

Sub AyirVeFormatla()
   
    Dim i As Long
    i = 2 ' Başlangıç hücresinin satır numarası
   
    Dim veri As String
    Dim isim As String
    Dim telefon As String
   
    ' B2 hücresinden başlayarak en son dolu hücreye kadar döngü
    Do While Cells(i, 2).Value <> ""
        veri = Cells(i, 2).Value
        veri = Replace(veri, "Tel:", "") ' Genel yapılan hata düzeltme
       
        ' İsim ve telefon numarasını ayırmak için
        isim = ""
        telefon = ""
       
        Dim c As Integer
        For c = 1 To Len(veri)
            Dim karakter As String
            karakter = Mid(veri, c, 1)
           
            If karakter Like "[A-Za-zçğıöşüÇĞİÖŞÜ ]" Then ' Türkçe karakterler dahil harfler ve ara boşlukları yakala
                isim = isim & karakter
            ElseIf karakter Like "[0-9]" Then ' sadece rakamları yakala
                telefon = telefon & karakter
            End If
        Next c
       
        ' Telefon verisinin ilk karakteri 0 ise bunu sil
        If Left(telefon, 1) = "0" Then
            telefon = Mid(telefon, 2)
        End If
       
        ' Telefon numarasını formatla
        If Len(telefon) <= 10 Then ' tel numarası 10 karakter ve hatalı olarak 10 karakterden küçükse
            telefon = "(" & Left(telefon, 3) & ") " & Mid(telefon, 4, 3) & " " & Mid(telefon, 7, 2) & " " & Mid(telefon, 9, 2)
        ElseIf Len(telefon) > 10 Then ' tel numara hatalı 10 karakterden fazla
            telefon = "(" & Left(telefon, 3) & ") " & Mid(telefon, 4, 3) & " " & Mid(telefon, 7, 2) & " " & Mid(telefon, 9, 2) & " " & Mid(telefon, 11)
        End If
       
        ' C ve D sütunlarına veri yaz
        Cells(i, 3).Value = Trim(isim)
        Cells(i, 4).Value = telefon
       
        i = i + 1 ' Bir sonraki satıra geç
    Loop
End Sub

Teşekkürler Hocam,
Sağ olun, var olun...