Otomatik Sıra Numarası

[Mikdad]

Selamun Aleykum Dostlarım,
ekli listede A8 hücresinden itibaren B8 hücresinden aşağıyı kontrol edip eğer dolu ise sıra numarası vermesini istiyorum. eğer b hücresinde veri yoksa sıra numarası vermeyecek. bu sıra numaraları 1 den başlayıp b hücresini kontrol edecek ve oto sıra numarası verecek.
Not: B sutununda formul var

 

[YUSUF44]

A8 hücresinde aşağıdaki formülü yazıp aşağıya doğru kopyalayın:

=EĞER(YADA(B8=0;B8="");"";BAĞ_DEĞ_DOLU_SAY($B$7:B8)-1)

 

[Mikdad]

Hocam, tam olarak istediğim gibi oldu. yanlız başka bir sorun oluştu.
aşağıdaki kod ile a sutununu kontrol edip yazdırıyordum. a sutununu kontrol edip dolu yere kadar yazdırıyordu. boş kısımları atlıyordu. ama şimdi sizin verdiğiniz kod ile o formulu uyguladığım tum A satırlarını dolu olarak görüyor. yardımcı olur musunuz lütfen

Sub Yazdır2()
'
' Yazdır Makro
'

'
    Application.Goto Reference:="Yazdır"
  ActiveSheet.PageSetup.PrintArea = "$A$1:$h$" & Range("A65536").End(3).Row
    Application.WindowState = xlNormal
    Range("C9").Select
    ActiveWindow.SmallScroll Down:=552
    Application.WindowState = xlMaximized
    ActiveWindow.SmallScroll Down:=-60
    ActiveWindow.ScrollRow = 489
    ActiveWindow.ScrollRow = 452
    ActiveWindow.ScrollRow = 420
    ActiveWindow.ScrollRow = 360
    ActiveWindow.ScrollRow = 295
    ActiveWindow.ScrollRow = 218
    ActiveWindow.ScrollRow = 117
    ActiveWindow.ScrollRow = 61
    ActiveWindow.ScrollRow = 25
    ActiveWindow.ScrollRow = 1
    ActiveSheet.Shapes.Range(Array("Oval 1")).Select
    Range("J9").Select
    ActiveWorkbook.Save
    Sheets("Gündem").Select
    Range("M3").Select
    ActiveWindow.SmallScroll Down:=-18
    Range("D8").Select
    'ActiveSheet.PrintOut Copies:=1
    ActiveSheet.PrintPreview
End Sub

 

[Mahir64]

Merhaba,
Alternatif olsun

=EĞER(B8>0;ALTTOPLAM(3;$B$7:B7);"")

 

[Mikdad]

Bunda da aynı sorun oluştu hocam

 

[YUSUF44]

Verdiğim formülü iptal edin makro olarak aşağıdaki makroyu kullanın:

Sub Yazdır2()
Application.Goto Reference:="Yazdır"
Sheets("Gündem").Select
yaz = 7
son = Cells(Rows.Count, "B").End(3).Row
For i = 8 To son
    If Cells(i, "B") = "" Or Cells(i, "B") = 0 Then
        Cells(i, "A") = ""
    Else
        Cells(i, "A") = WorksheetFunction.CountA(Range("B7:B" & i)) - 1
        yaz = i
    End If
Next
    ActiveSheet.PageSetup.PrintArea = "$A$1:$h$" & yaz
    ActiveWorkbook.Save
    Range("M3").Select
    Range("D8").Select
    'ActiveSheet.PrintOut Copies:=1
    ActiveSheet.PrintPreview
End Sub

Kodların sizin kodlarınıza eklenmiş hali aşağıdaki gibidir ama kırmızı yaptığım kodların gereksiz olduğunu düşündüğümden koddan çıkardım:

Sub Yazdır2()
'
' Yazdır Makro
'

'
Application.Goto Reference:="Yazdır"
yaz = 7
son = Cells(Rows.Count, "B").End(3).Row
For i = 8 To son
If Cells(i, "B") = "" Or Cells(i, "B") = 0 Then
Cells(i, "A") = ""
Else
Cells(i, "A") = WorksheetFunction.CountA(Range("B7:B" & i)) - 1
yaz = i
End If
Next
ActiveSheet.PageSetup.PrintArea = "$A$1:$h$" & yaz
Application.WindowState = xlNormal
Range("C9").Select
ActiveWindow.SmallScroll Down:=552
Application.WindowState = xlMaximized
ActiveWindow.SmallScroll Down:=-60
ActiveWindow.ScrollRow = 489
ActiveWindow.ScrollRow = 452
ActiveWindow.ScrollRow = 420
ActiveWindow.ScrollRow = 360
ActiveWindow.ScrollRow = 295
ActiveWindow.ScrollRow = 218
ActiveWindow.ScrollRow = 117
ActiveWindow.ScrollRow = 61
ActiveWindow.ScrollRow = 25
ActiveWindow.ScrollRow = 1
ActiveSheet.Shapes.Range(Array("Oval 1")).Select
Range("J9").Select
ActiveWorkbook.Save
Sheets("Gündem").Select
Range("M3").Select
ActiveWindow.SmallScroll Down:=-18
Range("D8").Select
'ActiveSheet.PrintOut Copies:=1
ActiveSheet.PrintPreview
End Sub

 

[Mikdad]

Yusuf hocam Allah Razı Olsun Yüreğinize Sağlık