Her 50 Sıradan Sonra B sutununa Sayfa1 ,Sayfa2 vs. yazsı

[yer06]

Sayın hocalarım; A Sutununda Sıra nolar var 3000 e kadar her 50 sıra nodan sonra B sutununa Sayfa1 , Sayfa2 ,Sayfa3 diyip sıra nonun sonuna gelene kadar yazdırabilirmiyiz. İstediğim dosya ektedir. Şimdiden teşekkür ederim

 

[Ziynettin]

Merhaba,
Bu şekilde denermisiniz

Sub sayfaadi_ver()
    Dim i As Long
    Dim son As Long
    Dim a As Integer
    
    Application.ScreenUpdating = False
            Range("B2:B" & Rows.Count).ClearContents

    a = 1
    son = Range("A" & Rows.Count).End(3).Row

        For i = 2 To son Step 50
            Cells(i, 2) = "Sayfa" & a
            a = a + 1
        Next i

    For i = 2 To son - 1
        If Cells(i + 1, 2) = "" Then Cells(i + 1, 2) = Cells(i, 2)
    Next i
    Application.ScreenUpdating = True
End Sub

 

[yer06]

ellerinize sağlık

 

[Emir Hüseyin Çoban]

. . .

Alternatif olarak

Sub kod()
Application.ScreenUpdating = False
syf = 0
Range("B:B").ClearContents

For i = 2 To [A65536].End(3).Row Step 50
syf = syf + 1

For a = i To [A65536].End(3).Row
Cells(a, "B") = "Sayfa" & syf
Next a
Next i

Application.ScreenUpdating = True
MsgBox " B i t t i "
End Sub

. . .

 

[Necdet]

Merhaba,

Bir başka seçenek, tek döngülü :

Sub Doldur()
 
    Dim i   As Long, _
        j   As Integer, _
        k   As Integer
 
    j = 0
    k = 50
 
    Application.ScreenUpdating = False
 
    For i = 2 To Cells(Rows.Count, "A").End(3).Row Step k
        j = j + 1
        Cells(i, "B") = "Sayfa" & j
        Range("B" & i & ":B" & i + k - 1).FillDown
    Next i
 
    Application.ScreenUpdating = True
 
End Sub

 

[yer06]

harikasınız ellerinize sağlık peki bu uygulamayı geliştirmek istersek ekdeki dosyada istenileni yapabilirmiyiz şimdiden teşekkür ederim.

 

[Necdet]

Merhaba,

Soruyu soruyorsunuz ama açık kapı da bırakıyorsunuz.
Örneğin kod yazacak olan kişi oturup düşünmeye başlıyor, acaba bu B sütunundaki isimler hep alt alta mıdır? karışık olabilir mi?

Buna göre yazılacak kodlarda farklılıklar olacaktır.

Sizin örneğinizde sanki alt alta sıralanmış gibi. bunu düşünerek yazılacak kod eğer farklı sıralıysa işinize yaramayacaktır.

İşin mantığını da zorlar bu durum.

Sıralı mı, değil mi? Yani 10 adet Ahmet'ten sonra 30 adet Mehmet mi geliyor? Yoksa Ahmet'ler ve Mehmet'ler karışık mı listede? vs vs vs.

 

[yer06]

isimler alt alta sıralı bir şekilde yani a1 ve a10 hücresinde 10 tane ahmet ismi yazıyorsa başka bir hücrede yazmıyor şimdiden teşekkür ederim.

 

[Necdet]

isimler alt alta sıralı bir şekilde yani a1 ve a10 hücresinde 10 tane ahmet ismi yazıyorsa başka bir hücrede yazmıyor şimdiden teşekkür ederim.

Düşünmeye başladım ama bu arada işler de çoğaldı.

işlerimi bitirene kadar kimseden yanıt gelmezse ilgileneceğim.

 

[Necdet]

Tekrar merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

İşlem adedinde baya kısıntı yapmak için uğraştım.

Klasik yüzlerce satır döngü ile de he kolay yoldan halletmek olası idi.

Sub Duzenle()
'
' Necdet YEŞERTENER
' [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]
' Kasım 2013, Ankara
'
    Dim i   As Long, _
        j   As Integer, _
        k   As Long, _
        kk  As Long, _
        Son As Long, _
        Kol As Integer, _
        Adt As Integer, _
        Grp As Integer, _
        c   As Range, _
        Mtn As String
        
    Application.ScreenUpdating = False
    
    Mtn = "Sayfa"
    Grp = 50
    Kol = Cells(1, Columns.Count).End(1).Column + 1
    i = Cells(Rows.Count, "B").End(3).Row
    
    Range("C2:C" & i).ClearContents
    Range("B1:B" & i).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, Kol), Unique:=True
    
    For j = 2 To Cells(Rows.Count, Kol).End(3).Row
        Set c = Range("B1:B" & i).Find(Cells(j, Kol), LookIn:=xlValues, LookAt:=xlWhole)
        Cells(j, Kol + 1) = c.Row   'Başlangıç Satır No
        Cells(j, Kol + 2) = Application.WorksheetFunction.CountIf(Range("B2:B" & i), Cells(j, Kol)) 'Adedi
        Adt = 0
        kk = Cells(j, Kol + 1) + Cells(j, Kol + 2) - 1
        
        For k = Cells(j, Kol + 1) To kk Step Grp
            Son = k + Grp
            If Son > kk Then Son = kk
            Adt = Adt + 1
            Range("C" & k & ":C" & Son) = Mtn & Adt
        Next k
    Next j
    
    Range(Cells(1, Kol), Cells(Rows.Count, Kol + 2)).ClearContents 'Geçici Kullanılan Sütunlar Siliniyor
    
    Application.ScreenUpdating = True
    
    MsgBox "İşlem Tamamlanmıştır...."
    
End Sub