[Çözüldü] Makro ile sıra no verme işlemi

[Hüseyin Çoban]

Merhaba Arkadaşlar,

Veri yönetimi sayfasında B sütununa 5. satırdan itibaren tarihler girdiğimde
A sütununda ilgili satırlara sıra no vermesini sağlayabilirmiyiz.

Formül ile yapılabilecek bir işlem ancak, formülü aşağı satırlara doğru uygulattıkça tablo boyutu çok yükseliyor. Tam kaç satıra uygulatmam gerektiğide belli değil.

Kod: [Seç]

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B6:B65536")) Is Nothing Then Exit Sub
    If Target <> "" Then
        Cells(Target.Row, "A") = WorksheetFunction.Max(Range("A5:A" & Target.Row - 1)) + 1
    Else
        Cells(Target.Row, "A") = ""
    End If
End Sub
işlemi bu kodlar ile çözmeye çalıştım ancak, tabloya uyarlamada sorun yaşadım. Tabloda düşeyara ve çarpma makrolarıda var.

Yardım ve fikirlerinizi bekliyorum.



[Forum yazılım güncelleme esnasında sorun oluştuğundan eklendi silinmiştir.]

[Rami]

Merhaba

Kodlarınızı aşağıdaki gibi deneyin.

Kod: [Seç]

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, Range("B6:B65536")) Is Nothing Then GoTo ff
    If Target <> "" Then
        Cells(Target.Row, "A") = WorksheetFunction.Max(Range("A5:A" & Target.Row - 1)) + 1
    Else
        Cells(Target.Row, "A") = ""
    End If
ff:
        If Not Intersect(Target, Range("E6:E65536")) Is Nothing Then
    On Error Resume Next
        If Target = "" Then Exit Sub
        If WorksheetFunction.CountIf(Sheets("hesap planı").Range("B:B"), Cells(Target.Row, "E")) > 0 Then
            Cells(Target.Row, "F") = WorksheetFunction.VLookup(Cells(Target.Row, "E"), Sheets("hesap planı").Range("B:c"), 2, 0)
            Else
        End If
         If WorksheetFunction.CountIf(Sheets("hesap planı").Range("B:B"), Cells(Target.Row, "E")) > 0 Then
            Cells(Target.Row, "G") = WorksheetFunction.VLookup(Cells(Target.Row, "E"), Sheets("hesap planı").Range("B:D"), 3, 0)
            Else
            'Cells(Target.Row, "E") = ""
            MsgBox " Girdiğiniz Hesap Kodu Hesap Planında Bulunamadı !", vbCritical
        End If
     End If
    If Intersect(Target, Range("D6:D65536,H6:I65536")) Is Nothing Then Exit Sub
    If UCase(Cells(Target.Row, "D")) = "B" Then
        Cells(Target.Row, "J") = Cells(Target.Row, "H") * Cells(Target.Row, "I")
        Cells(Target.Row, "K").ClearContents
    ElseIf UCase(Cells(Target.Row, "D")) = "A" Then
        Cells(Target.Row, "K") = Cells(Target.Row, "H") * Cells(Target.Row, "I")
        Cells(Target.Row, "J").ClearContents
    Else
        MsgBox "Lütfen kayıt türü bilgisini giriniz !", vbCritical
    End If
End Sub

[Hüseyin Çoban]

Sy Rami, çok teşekkürkler. Tam istediğim gibi olmuş sorunsuz çalışıyor. 
Emeğinize sağlık.