Soru İban Formatını hücre çıkışta uygulama

[htsumer]

Şöyle bir fonksiyonum var.

Function IBAN(IbanNo As String)
IBAN = "TR" & Format(Right(IbanNo, 24), "## #### #### #### #### #### ##")
End Function

B6 Hücresine ibanı yazdıktan sonra, yazılan ibanı formata göre değiştirsin.
Teşekkürler şimdiden

 

[muhasebeciyiz]

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("B6")) Is Nothing Then
        On Error GoTo ExitHandler
        Application.EnableEvents = False
     
        Dim IbanRaw As String
        IbanRaw = Replace(Target.Value, " ", "") ' Boşlukları temizle

        If Len(IbanRaw) = 26 And Left(IbanRaw, 2) = "TR" Then          
            Dim IbanBody As String
            IbanBody = Mid(IbanRaw, 3) ' TR sonrası 24 hane
       
            Target.Value = "TR" & " " & Format(IbanBody, "## #### #### #### #### #### ##")
        ElseIf Len(IbanRaw) = 24 Then
         
            Target.Value = "TR " & Format(IbanRaw, "## #### #### #### #### #### ##")
        Else
            MsgBox "IBAN en az 24 haneli olmalıdır.", vbExclamation
        End If

ExitHandler:
        Application.EnableEvents = True
    End If
End Sub

Hücreye yazılan IBAN'daki boşlukları temizliyor.
TR ile başlıyorsa ve toplam uzunluk 26 karakterse, biçimlendiriyor.
TR yoksa ve uzunluk 24 karakterse, başa TR ekleyip biçimlendiriyor.
B6 hücresine IBAN yazın (örneğin: 123456789012345678901234).

veya

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("B6")) Is Nothing Then
        Application.EnableEvents = False
        Dim formattedIban As String
        formattedIban = "TR" & Format(Right(Target.Value, 24), "## #### #### #### #### #### ##")
        Target.Value = formattedIban
        Application.EnableEvents = True
    End If
End Sub

Not: Eğer aynı sayfada (örneğin Sheet1) birden fazla Worksheet_Change prosedürü varsa, hata verir çünkü her sayfa için yalnızca bir tane Worksheet_Change alt programı tanımlanabilir.

1. Tüm Worksheet_Change alt programlarını kontrol edin.
2. Eğer birden fazla varsa, tek bir Worksheet_Change içinde tüm kontrolleri birleştirin.

 

[htsumer]

Function IBAN(IbanNo As String) As String
  
    If Len(IbanNo) >= 24 Then
        IBAN = "TR" & Format(Right(IbanNo, 24), "## #### #### #### #### #### ##")
    Else
        IBAN = "Hatalı giriş"
    End If
End Function

veya B6 Hücresine Giriş Yapıldığında Otomatik Formatlama
Bu işlemi Worksheet seviyesinde otomatik hale getirmek için aşağıdaki gibi bir Worksheet_Change olayı ekleyebilirsiniz:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B6")) Is Nothing Then
        Application.EnableEvents = False
        If Len(Target.Value) >= 24 Then
            Target.Value = "TR" & Format(Right(Target.Value, 24), "## #### #### #### #### #### ##")
        Else
            MsgBox "IBAN en az 24 karakter olmalıdır.", vbExclamation
        End If
        Application.EnableEvents = True
    End If
End Sub

Eğer B6 hücresine şunu yazarsanız:
123456789012345678901234
otomatik olarak şuna dönüşür:
TR12 3456 7890 1234 5678 9012 34

Fonksiyonu başka yerlerde de kullandığım için değişiklik yapamam.
İkinci verdiğiniz kod hücre çıkışlı olarak istedim
ikinci kodda hata aldım B6 hücresinde iban yazdıktan sonra enter dediğinde formatı düğzeltecek

 

[muhasebeciyiz]

Revize kodu denermisiniz

 

[htsumer]

Revize kodu denermisiniz

İki tane change kodu var diye mi hata veriyor anlamadım.

 

[volki_112]

Şöyle bir fonksiyonum var.

Function IBAN(IbanNo As String)
IBAN = "TR" & Format(Right(IbanNo, 24), "## #### #### #### #### #### ##")
End Function

B6 Hücresine ibanı yazdıktan sonra, yazılan ibanı formata göre değiştirsin.
Teşekkürler şimdiden

saynın kod bölümüne bunu yazın

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B6")) Is Nothing Then
        Application.EnableEvents = False ' Döngüyü önlemek için
        If Len(Target.Value) > 0 Then
            Target.Value = IBAN(Target.Value)
        End If
        Application.EnableEvents = True
    End If
End Sub

 

[volki_112]

İki tane change kodu var diye mi hata veriyor anlamadım.

Ekli dosyayı görüntüle 257824Ekli dosyayı görüntüle 257825

evet hata ondan. iki tane change kodu olmaz. Change kodlarını tek kodda birleştirin.

 

[htsumer]

evet hata ondan. iki tane change kodu olmaz. Change kodlarını tek kodda birleştirin.

O yüzden enter çıkışlı istedim exit kodla deniyeyim

 

[volki_112]

O yüzden enter çıkışlı istedim exit kodla deniyeyim

bu yapıştırın sayfanın kod bölümüne. Deneyiniz

Private previousValue As String

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(ActiveCell, Range("B6")) Is Nothing Then
        ' B6 seçildiğinde mevcut değeri al
        previousValue = Range("B6").Value
    Else
        ' Başka hücreye geçildiğinde ve B6'da değişiklik olduysa işlemi uygula
        If previousValue <> Range("B6").Value Then
            Application.EnableEvents = False
            If Len(Range("B6").Value) > 0 Then
                Range("B6").Value = IBAN(Range("B6").Value)
            End If
            Application.EnableEvents = True
        End If
    End If
End Sub

 

[htsumer]

bu yapıştırın sayfanın kod bölümüne. Deneyiniz

Private previousValue As String

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(ActiveCell, Range("B6")) Is Nothing Then
        ' B6 seçildiğinde mevcut değeri al
        previousValue = Range("B6").Value
    Else
        ' Başka hücreye geçildiğinde ve B6'da değişiklik olduysa işlemi uygula
        If previousValue <> Range("B6").Value Then
            Application.EnableEvents = False
            If Len(Range("B6").Value) > 0 Then
                Range("B6").Value = IBAN(Range("B6").Value)
            End If
            Application.EnableEvents = True
        End If
    End If
End Sub

Tamam bu kod ile çalıştı Teşekkür ederim.