Soru Plaka arasına boşluk ekleme.

[Garuramon]

Merhaba, EK' li olan dosyada makro ile plaka arasına boşluk eklenmesini sağlamak için nette araştırma yaptım. Bir tane makro buldum ancak çalıştıramadım, hata veriyor. Yardımlarınızı rica ediyorum.

 

[Muzaffer Ali]

Merhaba.

Kodları aşağıdakiler ile değiştirin.

Sub Plakayaboslukekle()
    Dim plaka As String, toplam As String, oncekiharf As String, harf As String
    Dim kontrol1 As Boolean, kontrol2 As Boolean
    Dim Bak As Long
    For Bak = 4 To Cells(Rows.Count, "E").End(xlUp).Row
        plaka = Cells(Bak, "E")
        toplam = Left(plaka, 1)
        For i = 2 To Len(plaka)
            oncekiharf = Mid(plaka, i - 1, 1)
            harf = Mid(plaka, i, 1)
            kontrol1 = IsNumeric(harf)
            kontrol2 = IsNumeric(oncekiharf)
            If harf = " " Then harf = ""
            If kontrol1 <> kontrol2 Then
                toplam = toplam & " "
            End If
            toplam = toplam & harf
        Next i
        Cells(Bak, "E") = toplam
    Next Bak
End Sub

 

[Necdet]

Merhaba,

Burayı İnceleyiniz.

 

[Garuramon]

Merhaba.

Kodları aşağıdakiler ile değiştirin.

Sub Plakayaboslukekle()
    Dim plaka As String, toplam As String, oncekiharf As String, harf As String
    Dim kontrol1 As Boolean, kontrol2 As Boolean
    Dim Bak As Long
    For Bak = 4 To Cells(Rows.Count, "E").End(xlUp).Row
        plaka = Cells(Bak, "E")
        toplam = Left(plaka, 1)
        For i = 2 To Len(plaka)
            oncekiharf = Mid(plaka, i - 1, 1)
            harf = Mid(plaka, i, 1)
            kontrol1 = IsNumeric(harf)
            kontrol2 = IsNumeric(oncekiharf)
            If harf = " " Then harf = ""
            If kontrol1 <> kontrol2 Then
                toplam = toplam & " "
            End If
            toplam = toplam & harf
        Next i
        Cells(Bak, "E") = toplam
    Next Bak
End Sub

Sayın @Muzaffer Ali ,

Üstteki kodları denediğim zaman EK' li olan resimdeki uyarı mesajı veriyor.

 

[Muzaffer Ali]

Sayın @Muzaffer Ali ,

Üstteki kodları denediğim zaman EK' li olan resimdeki uyarı mesajı veriyor.

Kesin kaynağını bilmiyorum ama,
Bu ileti dosyanız ile ilgili olmalı, kodlardan kaynaklı böyle bir ileti çıkmaz.

 

[Garuramon]

Sayın @Muzaffer Ali ,

Üstteki kodları denediğim zaman EK' li olan resimdeki uyarı mesajı veriyor.

Sayın @Muzaffer Ali,

Dosya-Seçenekler-Güven merkezi-güven merkezi ayarları-Belgeye özgü ayarlar kısmında "kaydederken dosya özelliklerinden kişisel bilgileri kaldır" seçeneğindeki tikini kaldırdım sorun düzeldi.

Formül gayet başarılı çalışıyor teşekkür ederim. Peki makro bilgi işlerken ( plaka yazılırken o an ) plakayı düzeltemez mi.

 

[Mdemir63]

Selamlar
Dosyayı inceleyiniz
Kodları Sitede bulmuştum.

 

[Garuramon]

Selamlar
Dosyayı inceleyiniz
Kodları Sitede bulmuştum.

Sayın @Mdemir63 ,

İlginiz için teşekkür ederim. Benim ihtiyacım olan veri girişi sırasında makronun çalışması. İyi çalışmalar dilerim.

 

[Garuramon]

Merhaba,

Burayı İnceleyiniz.

Sayın @Necdet ,

Paylaşmış olduğunuz sayfayı inceledim, sanırım benim ihtiyacım olan uygulama değil. Teşekkür ederim. İyi çalışmalar dilerim.

 

[Necdet]

Sayın @Necdet ,

Paylaşmış olduğunuz sayfayı inceledim, sanırım benim ihtiyacım olan uygulama değil. Teşekkür ederim. İyi çalışmalar dilerim.

Orada kullanılan fonksiyonu kendinize uyarlayabilirdiniz, ama hiç uğraşmadan hazıra konmak istiyorsunuz sanırım.

Aşağıdaki kodları ilgili sayfanın kod bölümüne kopyalayınız.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, [E:E]) Is Nothing Or Target.Row < 4 Then Exit Sub
    
    If Not Target.Value = "" Then Target.Value = PLAKA_KONTROL(UCase(Target.Value))
    
End Sub

Aşağıdaki kodları ise bir modüle kopyalayınız.

Function PLAKA_KONTROL(Plaka As String)

    Application.Volatile True
    Plaka = Replace(UCase(Plaka), " ", "")
    With CreateObject("VBScript.Regexp")
        .Pattern = "([0-9]{2})([A-Z]{1,4})([0-9]{2,4})"
        .Global = True
        PLAKA_KONTROL = .Replace(Plaka, "$1 $2 $3")
    End With
    
End Function

 

[Garuramon]

Orada kullanılan fonksiyonu kendinize uyarlayabilirdiniz, ama hiç uğraşmadan hazıra konmak istiyorsunuz sanırım.

Aşağıdaki kodları ilgili sayfanın kod bölümüne kopyalayınız.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, [E:E]) Is Nothing Or Target.Row < 4 Then Exit Sub
   
    If Not Target.Value = "" Then Target.Value = PLAKA_KONTROL(UCase(Target.Value))
   
End Sub

Aşağıdaki kodları ise bir modüle kopyalayınız.

Function PLAKA_KONTROL(Plaka As String)

    Application.Volatile True
    Plaka = Replace(UCase(Plaka), " ", "")
    With CreateObject("VBScript.Regexp")
        .Pattern = "([0-9]{2})([A-Z]{1,4})([0-9]{2,4})"
        .Global = True
        PLAKA_KONTROL = .Replace(Plaka, "$1 $2 $3")
    End With
   
End Function

Sayın @Necdet ,

Buraya konuyu açmadan önce netten benzer konuları araştırdım. Makro bilgim çok kısıtlı olduğu için kendime uyarlayamadım. Özellik hakkında yeterli bilgim olsa zaten ilk mesajımdaki makro kodunu kendi dosyama uyarlardım. Siz beni tamamen yanlış anladınız. İlgilendiğiniz için teşekkür ederim. İyi çalışmalar.

 

[Muzaffer Ali]

Sayın @Muzaffer Ali,

Dosya-Seçenekler-Güven merkezi-güven merkezi ayarları-Belgeye özgü ayarlar kısmında "kaydederken dosya özelliklerinden kişisel bilgileri kaldır" seçeneğindeki tikini kaldırdım sorun düzeldi.

Formül gayet başarılı çalışıyor teşekkür ederim. Peki makro bilgi işlerken ( plaka yazılırken o an ) plakayı düzeltemez mi.

Aşağıdaki kodu sayfanın kod kısmına kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim plaka As String, toplam As String, oncekiharf As String, harf As String
    Dim kontrol1 As Boolean, kontrol2 As Boolean
    If Not Intersect(Target, Range("E:E")) Is Nothing Then
        plaka = Target
        toplam = Left(plaka, 1)
        For i = 2 To Len(plaka)
            oncekiharf = Mid(plaka, i - 1, 1)
            harf = Mid(plaka, i, 1)
            kontrol1 = IsNumeric(harf)
            kontrol2 = IsNumeric(oncekiharf)
            If harf = " " Then harf = ""
            If kontrol1 <> kontrol2 Then
                toplam = toplam & " "
            End If
            toplam = toplam & harf
        Next i
        Application.EnableEvents = False
        Target = toplam
        Application.EnableEvents = True
    End If
End Sub

 

[Garuramon]

Aşağıdaki kodu sayfanın kod kısmına kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim plaka As String, toplam As String, oncekiharf As String, harf As String
    Dim kontrol1 As Boolean, kontrol2 As Boolean
    If Not Intersect(Target, Range("E:E")) Is Nothing Then
        plaka = Target
        toplam = Left(plaka, 1)
        For i = 2 To Len(plaka)
            oncekiharf = Mid(plaka, i - 1, 1)
            harf = Mid(plaka, i, 1)
            kontrol1 = IsNumeric(harf)
            kontrol2 = IsNumeric(oncekiharf)
            If harf = " " Then harf = ""
            If kontrol1 <> kontrol2 Then
                toplam = toplam & " "
            End If
            toplam = toplam & harf
        Next i
        Application.EnableEvents = False
        Target = toplam
        Application.EnableEvents = True
    End If
End Sub

Sayın @Muzaffer Ali ,

Kod doğru şekilde çalışıyor. Zaman ayırdığınız için teşekkür ederim. İyi çalışmalar.

 

[ahmetyildirim]

kodu veren arkadaşa teşekkürler.