Hücreye veri yazdırma

[furkani]

İyi günler arkadaşlar,

Ben fatura numarası girişi için bir kolaylık rica ediyorum, şöyle ki;
Temel numara TTK2021000000000 (TTK2021 sabit devamında 9 hane olacak şekilde)
Hücreye 1 yazdığımda TTK2021000000001 yazsın,
Hücreye 11 yazdığımda TTK2021000000011 yazsın,
Hücreye 111111 yazdığımda TTK2021000111111 yazsın gibi.

Şimdiden teşekkürler, iyi forumlar.

 

[Muzaffer Ali]

Merhaba.

Bunu yapmak istediğiniz sayfa adını sağ tıklatın "Kod Görüntüle" seçin, açılan sayfaya aşağıdaki kodlar kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A1:A1000")) Is Nothing Then
        If Target.Text = "" Then
            Exit Sub
        ElseIf Len(Target.Text) > 9 Then
            MsgBox "Bu hücreye 9 karakterden fazla giriş yapılamaz.", vbExclamation
            Target = ""
            Exit Sub
        End If
        Application.EnableEvents = False
        Target = "TTK2021" & WorksheetFunction.Rept("0", 9 - Len(Target)) & Target
        Application.EnableEvents = True
    End If
End Sub

Bu kodlar A1:A1000 aralığındaki hücrelerde çalışır, değiştirmek için şu satırda düzenleme yapın.

If Not Intersect(Target, Range("A1:A1000")) Is Nothing Then

 

[AdemCan]

Merhaba, deneme yaparken çözüm paylaşılmış ve aynı kodlar oldu ama hazırlamışken paylaşayım.

A sütununa göre çalışır, alt satırdaki 1 değerini istediğiniz bir sütun numarası ile değiştirebilirsiniz.
If Target.Column <> 1 Then Exit Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sabit As String, deger As Integer, kac_sifir As Byte, yeni_deger As String

If Target.Column <> 1 Then Exit Sub
    If Len(Target.Value) >= 16 Or Target.Value = Empty Then Exit Sub
        sabit = "TTK2021"
        deger = Target.Value
            If Len(Target.Value) > 9 Then
                MsgBox "Hatalı Fatura Numarası Girdiniz!", vbExclamation, "Uyarı"
                Target.Value = Empty
                Exit Sub
            End If
        kac_sifir = 9 - Len(Target.Value)
        yeni_deger = sabit & WorksheetFunction.Rept(0, kac_sifir) & deger
        Target.Value = yeni_deger

sabit = "": yeni_deger = ""
deger = 0: kac_sifir = 0
End Sub

 

[furkani]

Elinize sağlık.
Gayet güzel çalışıyor, ancak birden fazla hücreyi seçip delete yaptığımda;
If Len(Target.Value) >= 16 Or Target.Value = Empty Then
satırında hata veriyor.
Bilginize

 

[AdemCan]

If Target.Column <> 1 Then Exit Sub

ve

If Not Intersect(Target, Range("A1:A1000")) Is Nothing Then

satırlarından sonra

If Selection.Count > 1 Then Exit Sub

satırını ekleyiniz. Seçilen hücre sayısı 1 den büyük olursa diğer kodlar çalışmadan işlem sonlanır.

 

[furkani]

Süper, elinize sağlık. Saygılar,

 

[AdemCan]

Saygılar, iyi çalışmalar.

 

[Seyit Tiken]

Alternatif (makrosuz) :