Satır Say

[aligunes]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim s As Long
If Intersect(Target, Range("b16:b65536")) Is Nothing Then Exit Sub
For i = 16 To Range("b65536").End(3).Row
If Cells(i, 2).Value = "" Then
Cells(i, 1).Value = ""
Else
s = s + 1
Cells(i, 1).Value = s
End If
Next i
End Sub

Yukardaki kod 16. sutundan başlayarak b sutunu doluysa a sutununa numara vererek aşağı doğru sayıyor. Bu kodu şu şekilde nasıl yazabiliriz B sutunu dolu ise A sutununa sayı vererek sayacak B boş ise satırı atlayarak sayacak satır birleştirilmiş hücre ise saymaya bir alt satırdan devam edecek

 

[aligunes]

listeye sıra numarası vermek için kullanacağım ancak arada bazı sutunlar birleştirilmiş şekilde sayarken bu sutunları atlasın istiyorum

 

[Emir Hüseyin Çoban]

Örnek dosya olsa daha net çözüm olur.

.

 

[aligunes]

ÖRNEK DOSYA EKTEDİR.

 

[Emir Hüseyin Çoban]

#1 nolu mesajdaki kodları dosyanıza uyguladım. Doğru çalışıyor gibi geldi.
Araya yeni satırlar ekliyorum. Satırları birleştiriyorum. Doğru şekilde A kolonuna sıra numaralarını yazıyor.
Hata işlemleri görebileceğimiz, kodların da olduğu daha yardımcı olacak bir örnek kullanmalısınız.

.

 

[aligunes]

#1 nolu mesajdaki kodları dosyanıza uyguladım. Doğru çalışıyor gibi geldi.
Araya yeni satırlar ekliyorum. Satırları birleştiriyorum. Doğru şekilde A kolonuna sıra numaralarını yazıyor.
Hata işlemleri görebileceğimiz, kodların da olduğu daha yardımcı olacak bir örnek kullanmalısınız.

.

birleştirilmiş hücredeki yazıyı siliyor kod çalıştırıldığında

 

[Emir Hüseyin Çoban]

.

Private Sub Worksheet_Change(ByVal Target As Range)

    son = Cells(Rows.Count, "B").End(3).Row
    sec = Selection.Address
    If Intersect(Target, Range("B20:B" & son)) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    say = 1
    For i = 20 To son
        Cells(i, "A").Select

        If Selection.Address Like "*:*" Then GoTo satıratla

        If Cells(i, "B") = "" Then
            Cells(i, "A") = ""
        Else
            Cells(i, "A") = say
            say = say + 1
        End If
satıratla:
    Next i

    Range(sec).Select
    Application.ScreenUpdating = True
End Sub

.

 

[aligunes]

.

Private Sub Worksheet_Change(ByVal Target As Range)

    son = Cells(Rows.Count, "B").End(3).Row
    sec = Selection.Address
    If Intersect(Target, Range("B20:B" & son)) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    say = 1
    For i = 20 To son
        Cells(i, "A").Select

        If Selection.Address Like "*:*" Then GoTo satıratla

        If Cells(i, "B") = "" Then
            Cells(i, "A") = ""
        Else
            Cells(i, "A") = say
            say = say + 1
        End If
satıratla:
    Next i

    Range(sec).Select
    Application.ScreenUpdating = True
End Sub

.

eline sağlık kod çalışıyor.