• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

her 3 harften sonra boşluk bırakma

L

legendofskull

Katılım
13 Eylül 2015
Mesajlar
10
Excel Vers. ve Dili
Excel 2013 - İngilizce
Arkadaşlar merhaba,
Excel'deki metin dosyalarında değişiklik yapmak istiyorum.Her 3 harften sonra 1 boşluk ama noktalama işaretleri sayılmayacak.
Örnek:

Merhaba ben legendofskull.Şimdi bu yazıyı yazıyorum.

mer hab abe nle gen dof sku ll.ş imd ibu yaz ıyı yaz ıyo rum.

Amacım tam olarak bu.Maalesef metinler uzun olduğu için manuel olarak yapamıyorum.İşimi kolaylaştıracak bir makro kaydetmeyi denedim ama olmadı.
Yardımlarınız için şimdiden teşekkürler.
 
Alternatif;

Kod: 
Sub Uc_Harfte_Bir_Bosluk_Ekle()
    Columns(2).ClearContents
    
    Sembol = " .,;?!/+-*"
    
    For X = 1 To Cells(Rows.Count, 1).End(3).Row
        For Y = 1 To Len(Cells(X, 1))
            If InStr(1, Sembol, Mid(Cells(X, 1), Y, 1)) > 0 Then
                If Y = Len(Cells(X, 1)) Then
                    If Right(Veri, 1) = " " Then
                        Veri = Left(Veri, Len(Veri) - 1) & Mid(Cells(X, 1), Y, 1)
                    Else
                        Veri = Veri & Mid(Cells(X, 1), Y, 1)
                    End If
                Else
                        Veri = Veri & Mid(Cells(X, 1), Y, 1)
                End If
                If Right(Veri, 1) = " " Then Veri = Left(Veri, Len(Veri) - 1)
                If Say = 3 Then Veri = Veri & " ": Say = 0
            Else
                Veri = Veri & Mid(Cells(X, 1), Y, 1)
                Say = Say + 1
                If Say = 3 Then Veri = Veri & " ": Say = 0
            End If
        Next
        Cells(X, 2) = Trim(Veri)
        Veri = ""
    Next

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Alternatif;
Kod: 
[FONT="Trebuchet MS"][SIZE="2"]DefInt A, I, X: DefStr S
Sub Emre()
    Columns(2).[COLOR="Red"]ClearContents[/COLOR]
    For i = 1 To Range("A65536").End(3).Row
        For a = 1 To [COLOR="red"]Len[/COLOR](Cells(i, 1).Value) [COLOR="red"]Step [/COLOR]3
            s = [COLOR="red"]Mid[/COLOR](Cells(i, 1), a, 3)
            For x = 2 To Range("D65536").End(3).Row
                If [COLOR="red"]InStr[/COLOR](1, s, [COLOR="red"]CStr[/COLOR](Cells(x, 4).Value)) > 0 Then
                    s = [COLOR="red"]Mid[/COLOR](Cells(i, 1), a, 4)
                    a = a + 1
                End If
            Next x
            Cells(i, 2).Value = Cells(i, 2).Value & " " & s
        Next a
    Next i
    s = "": x = Empty: i = Empty: a = Empty
End Sub[/SIZE][/FONT]
 
Kod: 
Sub test()
    Columns(2).ClearContents
    Sembol = " .,;?!/+-*"
    For i = 1 To Cells(Rows.Count, 1).End(3).Row
        bol = Replace(Cells(i, 1).Value, " ", "")
        For ii = 1 To Len(bol)
            al = Mid(bol, ii, 1)
            If InStr(1, Sembol, al) = 0 Then Say = Say + 1
            Veri = Veri & al
            If Say = 3 Then Veri = Veri & " ": Say = 0
        Next
        Cells(i, 2) = Trim(Veri)
        Veri = ""
    Next
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Veysel bey kodlarımız benzer olmuş. Sondaki noktadan önce boşluk eklediği için araya sorgu satırları ekleme ihtiyacı hissettim.
 
Korhan Ayhan' Alıntı:
Veysel bey kodlarımız benzer olmuş. Sondaki noktadan önce boşluk eklediği için araya sorgu satırları ekleme ihtiyacı hissettim.
Genişletmek için tıkla ...

Benim gözümden kaçmış.

Kod: 
Sub test()
    Columns(2).ClearContents
    Dim par()
    Sembol = " .,;?!/+-*"
    For i = 1 To Cells(Rows.Count, 1).End(3).Row
        bol = Replace(Cells(i, 1).Value, " ", "")
        say = 0
        ReDim par(1 To Len(bol))
        For ii = 1 To Len(bol)
            al = Mid(bol, ii, 1)
            If InStr(1, Sembol, al) = 0 Then say = say + 1
            par(say) = par(say) & al
        Next
        ReDim Preserve par(1 To say)
        
        veri = "": say = 0
        For ii = 1 To UBound(par)
            say = say + 1
            veri = veri & par(ii)
            If say = 3 Then veri = veri & Space(1): say = 0
        Next
        
        Cells(i, 2) = Trim(veri)
    Next
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Sondaki nokta için ilave kontrol ile birlikte alternatif;

Kod: 
[FONT="Trebuchet MS"][SIZE="2"]DefInt A, I, X: DefStr S
Sub Emre()
    Columns(2).ClearContents
    For i = 1 To Range("A65536").End(3).Row
        For a = 1 To Len(Cells(i, 1).Value) Step 3
            s = Mid(Cells(i, 1), a, 3)
            For x = 2 To Range("D65536").End(3).Row
                If InStr(1, s, CStr(Cells(x, 4).Value)) > 0 Then
                    s = Mid(Cells(i, 1), a, 4)
                    a = a + 1
                End If
            Next x
            Cells(i, 2).Value = [COLOR="Red"]IIf[/COLOR]([COLOR="Blue"]Len[/COLOR](s) > 1, _
            Trim(Cells(i, 2).Value) & " " & s, Trim(Cells(i, 2).Value) & s)
        Next a
    Next i
    s = "": x = Empty: i = Empty: a = Empty
End Sub[/SIZE][/FONT]
 
Murat Bey incelemek üzere verdiğiniz kodu çalıştırdığımda, kelimeler arasındaki boşluklarda dahil edilerek 3 harf şeklinde ayrılıyor. Sanırım boşlukların olmaması gerekiyor.
 
Sn. saban20152015, bu kodları bir dener misiniz?

Kod: 
[FONT="Trebuchet MS"][SIZE="2"]Sub Emre()
    Dim isaret(), i%, say%, a%, y%, al$, yaz$
    isaret = Array(" ", ".", ";", "!", "?", "*", "-", "+")
    For i = 1 To Range("A65536").End(3).Row
        For a = 1 To Len(Cells(i, 1).Value)
            say = say + 1
            If say = 3 Then
                al = Mid(Cells(i, 1).Value, a - 2, say)
                For y = 0 To UBound(isaret)
                    If InStr(1, al, isaret(y)) > 0 Then
                        al = Replace(Mid(Cells(i, 1).Value, a - 2, say + 1), " ", "")
                        a = a + 1
                        say = Empty
                        Exit For
                    End If
                Next y
                say = Empty
                yaz = yaz & al & " "
            End If
            On Local Error Resume Next
            Cells(i, 2).Value = IIf(Right(Cells(i, 1).Value, 1) = _
            ".", Mid(yaz, 1, Len(yaz) - 1) & ".", yaz)
        Next a
    Next i
    i = Empty: a = Empty: say = Empty: al = "": yaz = ""
End Sub[/SIZE][/FONT]
 
Merhaba,
Öncelikle hepinize yardımlarınız için teşekkür ederim.Cevap veremediğim içinse özür dilerim internetimde sıkıntı vardı.Hemen kodları deneyeceğim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst