boşluklardan sonra yeniden başlayan sıra numarası

[unutkan518]

merhaba

a sütununda veriler bulunmakta aralarda boş satırlar mevcut. Sıra numarası verirken ilk satırdan başlayıp ilk boşluğa kadar sıra no verip sonrasında dolu hücreden devam edip sonraki boşluğa kadar 1 den başlayan yeni bir sıra no vermek istiyorum. yapmaya çalıştığım kod aşağıdaki gibidir.
Sub a()
Dim i, a, e As Integer
For i = 1 To 25
b = i
If Cells(i, 1).Value <> "" Then
For a = 1 To 3 'burayı dolu satır sayısı kadar yazarsam kod doğru çalışıyor
Cells(b, 2).Value = a
b = b + 1
Next a
End If
i = b
Next i
End Sub


olması gereken şekli
A sutunu b sutunu
veri-------------1
veri-------------2
veri-------------3
veri-------------4

veri-------------1
veri-------------2
veri-------------3


veri-------------1
veri-------------2

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Numara()

    Dim i As Long, s As Long
   
    [B:B].ClearContents
   
    For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(i, "A") = "" Then
            s = 0
        Else
            s = s + 1
            Cells(i, "B") = s
        End If
    Next
   
End Sub

 

[veyselemre]

Alternatif olsun;

Sub test()
    [B:B].ClearContents
    [B1] = 1
    With Range("B2:B" & Cells(Rows.Count, "A").End(xlUp).Row)
        .FormulaR1C1 = "=R[-1]C+1"
        .Offset(, -1).SpecialCells(xlCellTypeBlanks).EntireRow.ClearContents
        .Value = .Value
    End With
End Sub

 

[unutkan518]

Merhaba,

Bu şekilde deneyin.

Sub Numara()

    Dim i As Long, s As Long
  
    [B:B].ClearContents
  
    For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(i, "A") = "" Then
            s = 0
        Else
            s = s + 1
            Cells(i, "B") = s
        End If
    Next
  
End Sub

Ömer bey
numaralandırma doğru olarak çalıştı çok teşekkür eder iyi günler dilerim.

 

[unutkan518]

Alternatif olsun;

Sub test()
    [B:B].ClearContents
    [B1] = 1
    With Range("B2:B" & Cells(Rows.Count, "A").End(xlUp).Row)
        .FormulaR1C1 = "=R[-1]C+1"
        .Offset(, -1).SpecialCells(xlCellTypeBlanks).EntireRow.ClearContents
        .Value = .Value
    End With
End Sub

Veysel bey
teşekkür ederim. numaralandırma doğru çalışıyor

 

[unutkan518]

Merhaba,

Bu şekilde deneyin.

Sub Numara()

    Dim i As Long, s As Long
  
    [B:B].ClearContents
  
    For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(i, "A") = "" Then
            s = 0
        Else
            s = s + 1
            Cells(i, "B") = s
        End If
    Next
  
End Sub

sizden bir şey daha istesem yardımcı olabilir misiniz.
sıra numarasını verirken
sıra no / boşluğa kadar son sıra no yazdırılabilir mi acaba

aşağıda kırmızı ile işaretlenmiş hali gibi

olması gereken şekli
A sutunu b sutunu
veri-------------1/4
veri-------------2/4
veri-------------3/4
veri-------------4/4

veri-------------1/3
veri-------------2/3
veri-------------3/3


veri-------------1/2
veri-------------2/2

 

[unutkan518]

Alternatif olsun;

Sub test()
    [B:B].ClearContents
    [B1] = 1
    With Range("B2:B" & Cells(Rows.Count, "A").End(xlUp).Row)
        .FormulaR1C1 = "=R[-1]C+1"
        .Offset(, -1).SpecialCells(xlCellTypeBlanks).EntireRow.ClearContents
        .Value = .Value
    End With
End Sub

sizden bir şey daha istesem yardımcı olabilir misiniz.
sıra numarasını verirken
sıra no / boşluğa kadar son sıra no yazdırılabilir mi acaba

aşağıda kırmızı ile işaretlenmiş hali gibi

olması gereken şekli
A sutunu b sutunu
veri-------------1/4
veri-------------2/4
veri-------------3/4
veri-------------4/4

veri-------------1/3
veri-------------2/3
veri-------------3/3


veri-------------1/2
veri-------------2/2

 

[veyselemre]

Sub test()
    [b:b].ClearContents
    For Each Rng In [a:a].SpecialCells(XlCellType.xlCellTypeConstants).Areas
        With Rng.Offset(, 1)
            .NumberFormat = "@"
            say = 0
            For Each huc In .Cells
                say = say + 1
                huc.Value = say & "/" & Rng.Count
            Next huc
        End With
    Next
End Sub

 

[unutkan518]

Sub test()
    [b:b].ClearContents
    For Each Rng In [a:a].SpecialCells(XlCellType.xlCellTypeConstants).Areas
        With Rng.Offset(, 1)
            .NumberFormat = "@"
            say = 0
            For Each huc In .Cells
                say = say + 1
                huc.Value = say & "/" & Rng.Count
            Next huc
        End With
    Next
End Sub

Merhaba bu kodu aşağıdaki gibi dönüştürmek için nasıl bir değişiklik gerekiyor acaba yardımcı olabilirseniz sevinirim . Teşekkürler
Aynı veri isimlerine göre kodlama yapacak hale çevirmek istiyorum. Veri ismi tek yani benzersiz ise 1/1, iki tane ise 1/2 2/2 veya fazla ise 1/10 vs. gibi sıralamak istiyorum.

Arada satır boşlukları olmadan sıralama olması gerekiyor.

A sutunu b sutunu
veri-------------1/4
veri-------------2/4
veri-------------3/4
veri-------------4/4
elma------------1/3
elma------------2/3
elma------------3/3
armut-----------1/2
armut-----------2/2
kiraz-------------1/1
erik--------------1/2
erik--------------2/2
mandalina-------1/2
kiraz-------------1/1
mandalina-------2/2
nar---------------1/1

 

[Korhan Ayhan]

Merhaba,

Formülle çözüm;

B1 hücresine uygulayıp deneyiniz.

=EĞERSAY($A$1:A1;A1)&"/"&EĞERSAY(A:A;A1)

 

[Korhan Ayhan]

Bu da makrolu çözüm;

Option Explicit

Sub Sira_Numarasi_Ver()
    Dim Son As Long
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    Range("B:B").Clear
        
    With Range("B1:B" & Son)
        .Formula = "=COUNtIF(A1:A1,A1)&""/""&COUNTIF(A:A,A1)"
        .NumberFormat = "@"
        .Value = .Value
    End With
    
    MsgBox "Sıra numaraları güncellenmiştir.", vbInformation
End Sub

 

[unutkan518]

Bu da makrolu çözüm;

Option Explicit

Sub Sira_Numarasi_Ver()
    Dim Son As Long
   
    Son = Cells(Rows.Count, 1).End(3).Row
   
    Range("B:B").Clear
       
    With Range("B1:B" & Son)
        .Formula = "=COUNtIF(A1:A1,A1)&""/""&COUNTIF(A:A,A1)"
        .NumberFormat = "@"
        .Value = .Value
    End With
   
    MsgBox "Sıra numaraları güncellenmiştir.", vbInformation
End Sub

Korhan bey yardımınız için teşekkür ederim ikiside istediğim gibi çalıştı.