TLF. İçeren Hücrelerden Boşluk Silme

[kanakan52]

Merhaba arkadaşlar.
Çalışma kitabımda binlerce adres ve telefon numarası var. Fakat sabit bir sütunda değiller. Hepsinin ortak noktası "TLF." içeriyor olması. "TLF. içeren hücrelerdeki boşlukları silmek istiyorum. Yardımlarınızı rica ediyorum.

 

[Necdet]

Merhaba,

"TLF" içeren hücreye ait daha kapsamlı bir örnek veriniz ki sorun daha iyi anlaşılsın.

Aşağıdaki kodları deneyiniz, kendinize göre uyarlayınız.

kodları çalıştırmadan önce hücreleri seçiniz.

Sub BoslukSil()

    Dim Hcr As Range, _
        Adt As Long
    
    Application.ScreenUpdating = False
    
    For Each Hcr In Selection
        If InStr(1, Hcr, "TLF.", vbTextCompare) > 0 Then
            Adt = Adt + 1
            Hcr = Application.WorksheetFunction.Trim(Replace(Replace(Hcr, Chr(160), ""), Chr(10), " "))
        End If
    Next Hcr
    
    If Adt = 0 Then
        MsgBox "TLF içeren hiç bir hücreye rastlanmadı....."
    Else
        MsgBox Adt & " ADET HÜCRE DÜZELTİLDİ.."
    End If
        
    Application.ScreenUpdating = True
    
End Sub

 

[kanakan52]

Necdet bey, ilginize çok teşekkür ediyorum. Çalışma sayfasında değişik satırlarda ve sütunlarda "TLF. 0 346 221 2086" gibi bir sürü telefon numarası var. Bunların arasındaki boşlukları silip "TLF.03462212086" gibi olmasını istiyorum.

 

[kanakan52]

Necdet Bey maalesef çözüm olmadı.

Merhaba,

"TLF" içeren hücreye ait daha kapsamlı bir örnek veriniz ki sorun daha iyi anlaşılsın.

Aşağıdaki kodları deneyiniz, kendinize göre uyarlayınız.

kodları çalıştırmadan önce hücreleri seçiniz.

Sub BoslukSil()

    Dim Hcr As Range, _
        Adt As Long
    
    Application.ScreenUpdating = False
    
    For Each Hcr In Selection
        If InStr(1, Hcr, "TLF.", vbTextCompare) > 0 Then
            Adt = Adt + 1
            Hcr = Application.WorksheetFunction.Trim(Hcr)
        End If
    Next Hcr
    
    If Adt = 0 Then
        MsgBox "TLF içeren hiç bir hücreye rastlanmadı....."
    Else
        MsgBox Adt & " ADET HÜCRE DÜZELTİLDİ.."
    End If
        
    Application.ScreenUpdating = True
    
End Sub

 

[Necdet]

Merhaba,

Önce işlem yapılacak hücreleri seçeceksiniz, sonra kodları çalıştıracaksınız.

 

[kanakan52]

Hepsini denedim üstat. x adet hücre düzeltildi mesajı veriyor lakin herhangi bir düzelme olmuyor.

 

[yusufelmas]

Merhaba,
Hocam tüm numaralar aynı formatta mı?
Eğer hepsi aynı formattaysa basit bir kodla halledilir.
Necdet beyin koduna bir ekleme yaptım.

Sub sil()
Dim cell as Range
For Each cell In Selection
If Instr(1,cell,"TLF.",vbTextCompare)>0 Then
cell=Mid(cell,1,4) & "0" & Mid(cell,8,3) & Mid(Cell,12,3) & Mid(Cell,16,2) & Mid(Cell,19,2)
EndIf
Next cell
End Sub

 

[kanakan52]

Üstat, kodlarınız bir nevi işe yaradı... Tüm numaralar aynı formatta değil sıkıntı ordan doğuyor. Düzelenler de oldu tamamen alakasız olanlar da.

Merhaba,
Hocam tüm numaralar aynı formatta mı?
Eğer hepsi aynı formattaysa basit bir kodla halledilir.
Necdet beyin koduna bir ekleme yaptım.

Sub sil()
Dim cell as Range
For Each cell In Selection
If Instr(1,cell,"TLF.",vbTextCompare)>0 Then
cell=Mid(cell,1,4) & "0" & Mid(cell,8,3) & Mid(Cell,12,3) & Mid(Cell,16,2) & Mid(Cell,19,2)
EndIf
Next cell

 

[YUSUF44]

Sayın Necdet Beyin kodlarından yararlandığım aşağıdaki kodları deneyiniz:

Sub BoslukSil()

    Dim Hcr As Range

    Application.ScreenUpdating = False
    
    For Each Hcr In UsedRange
        If InStr(1, Hcr, "TLF.", vbTextCompare) > 0 Then
            Hcr = Replace(Hcr, " ", "")
        End If
    Next Hcr
    
          
    Application.ScreenUpdating = True
    
End Sub

 

[kanakan52]

Teşekkür ederim emeğinize sağlık.

Sayın Necdet Beyin kodlarından yararlandığım aşağıdaki kodları deneyiniz:

Sub BoslukSil()

    Dim Hcr As Range


Application.ScreenUpdating = False
    
    For Each Hcr In UsedRange
        If InStr(1, Hcr, "TLF.", vbTextCompare) > 0 Then
            Hcr = Replace(Hcr, " ", "")
        End If
    Next Hcr
    
          
    Application.ScreenUpdating = True
    
End Sub

 

[Seyit Tiken]

 

[Necdet]

Merhaba,

Büyük olasılıkla sizin boşluk dediğiniiz boşluk değildir.

2 numaralı mesajımı düzelttim, tekrar bakınız.

 

[kanakan52]

Geç cevap için özür dilerim. İlk önce bunu düşündüm. Örnek A sütununda hem firma ismi hem adres hem de telefon olduğundan dolayı bu sütundaki tüm boşlukları kaldırdı. Yine de ilginize teşekkür ediyorum. Emeğinize sağlık