Noktalama İşaretleri Yerine "." Kullanma ve Çoklu boşlukları Tek Boşluğa İndirme

[kasif2]

Noktalama İşaretleri Yerine "." Kullanma ve Çoklu boşlukları Tek Boşluğa İndirme

Selam;

Option Explicit
 
Sub DÜZENLE()
    Dim HÜCRE As Range, KARAKTER() As Variant, X As Byte
 
    KARAKTER = Array(" ", "'", "´", "`", ":", ";", "=", ".", ",", "-", "+", "~*", "/", "(", ")", """", "!", "^", "$", "#", "%", "&", "{", "[", "]", "}", "\", "~?", "_", "<", ">", "|", "@", "¨", "~")
 
    For Each HÜCRE In Range("A2:A" & Range("A65536").End(3).Row)
        If HÜCRE.Value <> "" Then
            HÜCRE.Offset(0, 1) = HÜCRE.Value
            For X = 0 To UBound(KARAKTER)
                HÜCRE.Offset(0, 1).Replace What:=KARAKTER(X), Replacement:="."
            Next
        End If
    Next
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Korhan Ayhan a çok teşekkürler. Noktalama işaretlerini noktaya çeviren bu makrosunu buldum siteden, çok işime yaradı ama 4 - 5 boşluk olabiliyor onları da tek boşluklu hale getirmek istiyorum. Kırp formülü ile de yapılabilir ama yeni bi sütun eklememek için koda onu da eklemek mümkün mü acaba....

 

[halit3]

Selam;



Korhan Ayhan a çok teşekkürler. Noktalama işaretlerini noktaya çeviren bu makrosunu buldum siteden, çok işime yaradı ama 4 - 5 boşluk olabiliyor onları da tek boşluklu hale getirmek istiyorum. Kırp formülü ile de yapılabilir ama yeni bi sütun eklememek için koda onu da eklemek mümkün mü acaba....

Buradan sonra

HÜCRE.Offset(0, 1).Replace What:=KARAKTER(X), Replacement:="."

bunu ekleyin

HÜCRE.Offset(0, 1) = WorksheetFunction.Trim(HÜCRE.Offset(0, 1))

 

[kasif2]

Çok teşekkürler, halloldu, 2500 satır olunca biraz yavaş oluyo ama diğerlinden daha hızlı

 

[kasif2]

Peki bunu aynı hücrede yapma şansımız var mı?

buradaki makro ile B hücresindeki değişikliği C sütununa yazdırıyor, ben aynı hücrede değişiklik yapsın istiyorum.

 

[kasif2]

Aşağıdaki kod ile C sütunu ve F sütununda istediğim değişiklikleri üzerinde yapabildim..

Sub VirgulYildizBoslukSil()
    Range("C4:C10000").Select
    Selection.Replace What:="~*", Replacement:=" ", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:=",", Replacement:=" ", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="  ", Replacement:=" ", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="..", Replacement:=".", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Range("F4:F10000").Select
    Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub