Macro ile otomatik sıra numarası verme

[86126]

Arkadaşlar
A sutununda sıra no nun altına B sutununda veri oldukça A3 ten
itibaren otomatik numaralandırmasını istiyorum.

Ancak bazı noktalarda birleştirilmiş hücreler mevcut bunlarda ara başlıklar var
onları atlamasını istiyorum.

zaman zamanda tabloma yeni ara başlık veya satır ekliyorum. Bununda dikkate alınması gerekiyor.

Yardımlarınızı bekliyorum Şimdiden teşekkürler.

 

[Korhan Ayhan]

Merhaba,

Sayfanızın kod bölümüne aşağıdaki kodu uygulayın.

B sütununa veri girip deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim X As Long, No As Long
    
    If Intersect(Target, Range("B4:B65536")) Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    
    For X = 4 To Selection.SpecialCells(xlCellTypeLastCell).Row
        If Cells(X, "A").MergeArea.Count = 1 Then
            If Cells(X, "B") <> "" And Cells(X, "A") <> "Sıra No" Then
                No = No + 1
                Cells(X, "A") = No
            Else
                If Cells(X, "A") <> "Sıra No" Then
                    Cells(X, "A").ClearContents
                End If
            End If
        End If
    Next
    
    Application.ScreenUpdating = True
End Sub

 

[86126]

Korhan Hocam çok teşekkür ederim.Tam istediğim gibi ancak ara başlığın altına yine sütun başlığı metin yazıyorum. Bu kez onları silip numara veriyor. Metin girdiğimizde sıra numarasını atlatabilirmiyiz. Ve ayrıca örneğin A sütununda birleştirilmişmi alt alta iki veya üç hücreyede sıra numarası vermesini sağlayabilirmiyiz.

 

[Korhan Ayhan]

Merhaba,

Üstteki mesajımdaki kodu güncelledim. Denermisiniz.

 

[86126]

Hocam Teşekkür ederim. Anladım kadarı ile sadece Sıra no yazarsam silmiyor ve numara vermiyor. S.NO gibi yazarsam siliyor ve numara veriyor. Emeğiniz için teşekkür ederim.

 

[86126]

Yukarıdaki kodu çalışma kitabının bütün sayfalarında nasıl geçerli kılabiliriz Hocam. Şimdiden teşekkürler. Ayrıca birleştirilmiş hücrelerdede geçerli yapabilirmiyiz.

 

[86126]

Arkadaşlar yardımlarınızı bekliyorum.

 

[Mavirenk]

Korhan Ayhan hocam çok teşekkürler ellerinize sağlık

 

[khthonik]

Merhaba,

Korhan Bey'in üstteki yorumlarındaki kodu kendi sayfama göre değiştirdim.

1- Alttaki kodlar ilgili sayfanın vbasında çalışıyordu. Ama altta bolt olarak yazdığım kısmı eklemek istiyorum. Bu ilave ile çalışabilir hale getirilebilir mi?
2- Kodlar exceli çok kastırıyor. Daha hızlı çalışır hale getirilebilir mi?

Private Sub Worksheet_Change(ByVal Target As Range)
Dim X As Long, No As Long

If Intersect(Target, Range("J4:M65536")) Is Nothing Then Exit Sub

Application.ScreenUpdating = False
Application.EnableEvents = False

'ws1.Unprotect Password:="ESY"

For X = 4 To Selection.SpecialCells(xlCellTypeLastCell).Row

If Cells(X, "E") <> "" Then
Cells(X, "A") = Cells(X, "J") & Cells(X, "K") & Cells(X, "L") & Cells(X, "M")
son = Cells(X, "A").End(xlUp).Row
Cells(X, "B") = WorksheetFunction.CountIf(Range("A4:A" & son), Cells(X, "A"))
If Cells(X, "B").Value > 1 Then
Range("E" & X).Interior.ColorIndex = 38
Else
Range("E" & X).Interior.ColorIndex = xlNone
End If
End If

If Intersect(Target, Range("E4:E65536")) Is Nothing Then Exit Sub

If Cells(X, "C").MergeArea.Count = 1 Then
If Cells(X, "E") = "Yeni" And Cells(X, "C") <> "Sıra No" Then
No = No + 1
Cells(X, "C") = No
Else
If Cells(X, "C") <> "Sıra No" Then
Cells(X, "C").ClearContents
End If
End If
End If
End If
Next

Application.ScreenUpdating = True
Application.EnableEvents = True

'Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True, Password:="ESY"

End Sub

Saygılar..