hücredeki iletişim bilgisinin içinden telefon numarasını çekme

[pNouma]

Kıymetli Hocalarım merhaba,
Ekli linkte yer alan dosyada görüneceği üzere personel adı, adres bilgileri ile birlikte telefon numaraları yazmakta; yalnız telefon numaralarıı formatı standart değil, şöyleki kiminde boşluklu yazılmış durumda, yada "()" "-" işaretleri kullanılmış,

telefon numaraları bazı satırlarda ortada, bazı satırlarda sonda yazıyor.

https://dosya.co/s3mp8w6g4o41/Kitap2.xlsx.html

burada yer alan telefon numaralarını isimlerini almak için nasıl bir makro kodu yazabiliriz?

Desteğiniz için şimdiden teşekkürler,
iyi çalışmalar.

 

[mustafa1205]

Sub TelefonlariCek()
Dim ws As Worksheet
Dim sonSatir As Long, i As Long
Dim veri As String, tel As String

Set ws = ThisWorkbook.ActiveSheet
sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

For i = 1 To sonSatir
veri = ws.Cells(i, "A").Value
tel = TelBul(veri)
ws.Cells(i, "B").Value = tel
Next i

MsgBox "Telefon numaraları B sütununa aktarıldı.", vbInformation
End Sub

Function TelBul(ByVal s As String) As String
Dim i As Long, ch As String, d As String, cnt As Long

For i = Len(s) To 1 Step -1
ch = Mid$(s, i, 1)
If ch >= "0" And ch <= "9" Then
d = d & ch
cnt = cnt + 1
If cnt = 11 Then Exit For
End If
Next i

If cnt = 0 Then
TelBul = ""
Exit Function
End If

d = StrReverse(d)
If Len(d) = 10 Then d = "0" & d

If Len(d) = 11 Then
TelBul = Left$(d, 1) & " " & Mid$(d, 2, 3) & " " & Mid$(d, 5, 3) & " " & Mid$(d, 8, 2) & " " & Right$(d, 2)
Else
TelBul = d
End If
End Function


Deneyiniz...

 

[pNouma]

Sub TelefonlariCek()
Dim ws As Worksheet
Dim sonSatir As Long, i As Long
Dim veri As String, tel As String

Set ws = ThisWorkbook.ActiveSheet
sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

For i = 1 To sonSatir
veri = ws.Cells(i, "A").Value
tel = TelBul(veri)
ws.Cells(i, "B").Value = tel
Next i

MsgBox "Telefon numaraları B sütununa aktarıldı.", vbInformation
End Sub

Function TelBul(ByVal s As String) As String
Dim i As Long, ch As String, d As String, cnt As Long

For i = Len(s) To 1 Step -1
ch = Mid$(s, i, 1)
If ch >= "0" And ch <= "9" Then
d = d & ch
cnt = cnt + 1
If cnt = 11 Then Exit For
End If
Next i

If cnt = 0 Then
TelBul = ""
Exit Function
End If

d = StrReverse(d)
If Len(d) = 10 Then d = "0" & d

If Len(d) = 11 Then
TelBul = Left$(d, 1) & " " & Mid$(d, 2, 3) & " " & Mid$(d, 5, 3) & " " & Mid$(d, 8, 2) & " " & Right$(d, 2)
Else
TelBul = d
End If
End Function


Deneyiniz...

Teşekkürler Mustafa Hocam
iyi hafta sonları dilerim.

 

[halit3]

Alternatif olarak KTF

Formül = telefonno(A1)

Function telefonno(hucre)

hucre = Replace(Replace(Replace(Replace(hucre, "(", ""), ")", ""), "-", ""), " ", "")

For k = 1 To Len(hucre)

If IsNumeric(Mid(hucre, k, 1)) = True Then
If IsNumeric(Mid(hucre, k, 11)) = True Then
If Len(Mid(hucre, k, 11)) > 10 Then
telefonno = Trim(Mid(hucre, k, 11))

GoTo atla
ElseIf IsNumeric(Mid(hucre, k, 10)) = True Then
If Len(Mid(hucre, k, 11)) > 10 Then
telefonno = Trim(Mid(hucre, k, 10))

End If
End If
End If
End If
Next k
atla:

End Function

 

[hasankardas]

Alternatif olsun
Power Query de

let
    Kaynak = Excel.Workbook(File.Contents("dosyayolu\Kitap2.xlsx"), null, true),
    Sayfa1_Sheet = Kaynak{[Item="Sayfa1",Kind="Sheet"]}[Data],
    #"Değiştirilen Tür" = Table.TransformColumnTypes(Sayfa1_Sheet,{{"Column1", type text}}),
    #"Telefon Ayıklandı" = Table.AddColumn(#"Değiştirilen Tür", "Telefon", each try Text.Middle(Text.Select([Column1], {"0".."9"}), Text.PositionOf(Text.Select([Column1], {"0".."9"}), "05"), 11) otherwise null)
in
    #"Telefon Ayıklandı"

 

[pNouma]

Alternatif olarak KTF

Formül = telefonno(A1)

Function telefonno(hucre)

hucre = Replace(Replace(Replace(Replace(hucre, "(", ""), ")", ""), "-", ""), " ", "")

For k = 1 To Len(hucre)

If IsNumeric(Mid(hucre, k, 1)) = True Then
If IsNumeric(Mid(hucre, k, 11)) = True Then
If Len(Mid(hucre, k, 11)) > 10 Then
telefonno = Trim(Mid(hucre, k, 11))

GoTo atla
ElseIf IsNumeric(Mid(hucre, k, 10)) = True Then
If Len(Mid(hucre, k, 11)) > 10 Then
telefonno = Trim(Mid(hucre, k, 10))

End If
End If
End If
End If
Next k
atla:

End Function

Halit Hocam çok teşekkür ederim.

 

[Korhan Ayhan]

Alternatif...

Formülle çözüm..

Paylaştığınız dosyaya göre düzenlenmiştir. Asıl dosyanızda farklı formatlar varsa farklı sonuçlar verebilir..

=EĞERHATA(METNEÇEVİR(PARÇAAL(YERİNEKOY(YERİNEKOY(YERİNEKOY(YERİNEKOY(A1;"(";"");")";"");"-";"");" ";"");MBUL("05";YERİNEKOY(YERİNEKOY(YERİNEKOY(YERİNEKOY(A1;"(";"");")";"");"-";"");" ";""));11);"[<=9999999]###-####;(###) ###-####");"")

 

[mustafa1205]

Teşekkürler Mustafa Hocam
iyi hafta sonları dilerim.

İyi Çalışmalar dilerim