Otomatik sıra no ver

[ASLAN7410]

Merhaba hayırlı geceler.

Ekte gönderdiğim excel sayfamda A sütununda sıra numarasını otomatik veren kod var.

Benim istediğim B sütunundaki en alt tarafındaki bilgilerden sildikçe de, A sütununun en alt taraftaki sıra numaraları da otomatik silmesini istiyorum.
Yani B sütunundaki bilgilere göre A sütununa sıra no verip silecek.

Yardım eder misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B2:B1048576]) Is Nothing Then Exit Sub
    With Sheets(1).Range("A2:A" & Sheets(1).[B1048576].End(3).Row)
        .Formula = "=IF(B2<>"""",MAX($A$1:A1)+1,"""")"
        .Value = .Value
    End With
End Sub

 

[turist]

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B2:B1048576]) Is Nothing Then Exit Sub
    With Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
        .Formula = "=IF(B2<>"""",MAX($A$1:A1)+1,"""")"
        .Value = .Value
    End With
End Sub

 

[ASLAN7410]

Sayın turist hayırlı geceler, ilginiz için çok teşekkür ediyorum.

Göndermiş olduğunuz kodu sayfama uyguladığımda B sütunundaki en alttan bilgi sildiğim de A sütununda sıra numarasını siliyor, burası tam istediğim gibi olmuş elinize sağlık.

Ancak B sütununa bilgi girdiğim A sütununda sıra no vermiyor.

 

[turist]

 With Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row + 1)

satırda bu şekilde değiştirin.

 

[ASLAN7410]

Sayın turist hayırlı sabahlar.

Kod gayet güzel çalıştı, ancak bu seferde B sütununda arada boşluk atladığımda yine A sütununda sıra no vermedi.

 

[askm]

Aşağıdaki gibi bir deneyin.

Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Application.ScreenUpdating = False

On Error Resume Next
If ActiveCell.Column = 2 Then
Cells(Target.Row, 1) = Sayfa1.Cells(Target.Row - 1, 1) + 1
If Cells(Target.Row, 2) = "" Then Cells(Target.Row, 1).ClearContents
Else
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

 

[ASLAN7410]

Sayın askm ilginiz için çok teşekkür ederim, ancak benim istediğim gibi olmadı, sizin yazmış olduğunuz kod çalışması ile ilgili xxx isimli örnek resim gönderiyorum.


Benim istediğim B sütununda ne kadar boşluk olursa olsun, B sütunundaki en son dolu hücreye kadar kontrol edip A sütununda sıra numarası vermesini istiyorum.

Yapmak istediğim resim ekte.

 

[YUSUF44]

Anladığım kadarıyla aşağıdaki kodları ilgili sayfanın kod bölümüne yapıştırırsanız B sütununa veri girdikçe A sütununa sıra numarası verir:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B2:B1048576]) Is Nothing Then Exit Sub
    For i = 2 To Cells(Rows.Count, "B").End(3).Row
        Cells(i, "A") = i - 1
    Next
    
End Sub

Eğer B sütunundaki son dolu hücreyi değiştirdiğinizde A sütunundaki eski verilerin silinmesini ve yeniden B'deki son dolu hücreye kadar işlem yapılmasını istiyorsanız aşağıdaki gibi kullanınız:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B2:B1048576]) Is Nothing Then Exit Sub
    eski = WorksheetFunction.Max(2, Cells(Rows.Count, "A").End(3).Row)
    Range("A2:A" & eski).ClearContents
    For i = 2 To Cells(Rows.Count, "B").End(3).Row
        Cells(i, "A") = i - 1
    Next
    
End Sub

 

[Necdet]

Merhaba,

Alternatif olsun.

Aşağıdaki kodları ilgili sayfanın kod bölümüne kopyalayın, ilgili satırda herhangi bir hücreye canınızın istediğinde çift tıklayın numaralandırsın.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim SonSatB As Long
    
    SonSatB = Cells(Rows.Count, "B").End(3).Row
    
    Range("A2") = 1
    Range("A2:A" & SonSatB).DataSeries
    
End Sub

 

[turist]

Sayın turist hayırlı sabahlar.

Kod gayet güzel çalıştı, ancak bu seferde B sütununda arada boşluk atladığımda yine A sütununda sıra no vermedi.

Bu türde kullanmak istediğinizde B sütununda arada boşluk olsa da A sütununa sıra numarası verecektir.Oysa ilk mesajınızda;

Benim istediğim B sütunundaki en alt tarafındaki bilgilerden sildikçe de, A sütununun en alt taraftaki sıra numaraları da otomatik silmesini istiyorum

diyordunuz.Bu durumda ne olması gerekir sizce.?
Aşağıdaki kodu deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B2:B1048576]) Is Nothing Then Exit Sub
    With Range("A2:A" & Range("B" & Rows.Count).End(xlUp).Row)
        .Formula = "=MAX($A$1:A1)+1"
        .Value = .Value
    End With
End Sub

 

[ASLAN7410]

Sayın YUSUF44 aşağıda yazmış olduğunuz kod gayet güzel çalışıyor tam benim istediğim gibi olmuş ellerinize sağlık.

Yeni bir bilgiye de ihtiyaç duyulduğundan bir istediğim olacak, aşağıdaki kodu K sütununa kadar nasıl uzatabiliriz?

Yani B ile K sütunu arasında hangi sütun doluysa A sütununda ona göre sıra numarası versin, ilgili sütunlardaki bilgileri sildiğimde de A sütununda sıra numarasını yeniden sıra no versin.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B2:B1048576]) Is Nothing Then Exit Sub
    eski = WorksheetFunction.Max(2, Cells(Rows.Count, "A").End(3).Row)
    Range("A2:A" & eski).ClearContents
    For i = 2 To Cells(Rows.Count, "B").End(3).Row
        Cells(i, "A") = i - 1
    Next
End Sub

 

[YUSUF44]

Target'i B2:K istediğiniz kadar yapın.

Eski satırından sonra

b=WorksheetFunction.Max(2, Cells(Rows.Count, "B").End(3).Row)

Satırını ekleyin. Bu B sütunundaki son dolu satırı bulacak.
Aynı işlemi K'ya kadar her sütun için ayrı ayrı yapın (c=WorksheetFunction.Max.... Gibi)

For satırından önce

son=WorksheetFunction.Max(b, c, d, e, f, g, h, i, j, k)

Satırını ekleyin.

For satırını

For i = 2 to son

Olarak değiştirip deneyin. Ben cepten deneyemedim.

 

[ASLAN7410]

Sayın YUSUF44 Bey ilginiz için çok teşekkür ediyorum, sizin dediğiniz gibi aşağıdaki kodu ayarladım, gayet güzel çalışıyor, çok teşekkür ediyorum.
Hayırlı çalışmalar hayırlı geceler.

Ayrıca soruma cevap veren herkese çok teşekkür ediyorum.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B2:K1048576]) Is Nothing Then Exit Sub

    Eski = WorksheetFunction.Max(2, Cells(Rows.Count, "A").End(3).Row)
    b = WorksheetFunction.Max(2, Cells(Rows.Count, "B").End(3).Row)
    c = WorksheetFunction.Max(2, Cells(Rows.Count, "C").End(3).Row)
    d = WorksheetFunction.Max(2, Cells(Rows.Count, "D").End(3).Row)
    e = WorksheetFunction.Max(2, Cells(Rows.Count, "E").End(3).Row)
    f = WorksheetFunction.Max(2, Cells(Rows.Count, "F").End(3).Row)
    g = WorksheetFunction.Max(2, Cells(Rows.Count, "G").End(3).Row)
    h = WorksheetFunction.Max(2, Cells(Rows.Count, "H").End(3).Row)
    i = WorksheetFunction.Max(2, Cells(Rows.Count, "i").End(3).Row)
    j = WorksheetFunction.Max(2, Cells(Rows.Count, "J").End(3).Row)
    k = WorksheetFunction.Max(2, Cells(Rows.Count, "K").End(3).Row)
    
    Range("A2:A" & Eski).ClearContents
    son = WorksheetFunction.Max(b, c, d, e, f, g, h, i, j, k)
    For i = 2 To son
        Cells(i, "A") = i - 1
    Next
End Sub