liste parçalama

[EErkut]

Merhabalar,

Elimde çok satırlı ve adetli bir liste var. Bu listeyi belirlenen adet toplamına göre bölmek istiyorum. Örnek olarak B sütünündaki adetler maksimum 600'e kadar olacak şekilde aralar boş satır ekleyerek ya da yeni sayfalara bölerek listeyi parçalamak istiyorum. Her liste toplamı maksimum 600 olacak.

Bu konuda önereceğiniz bir yöntem var mı?

Dekteğiniz için şimdiden teşekkür ederim.

 

[ÖmerFaruk]

Altın üyesiniz.
Manuel çözümü de içeren örnek bir dosya paylaşır mısınız?

 

[kulomer46]

Merhaba

Konu hakkında 5 Mayıs 2020 tarihinde yazılmış 2 adet dosya Ek 'te eklenmiştir.

Selamlar...

 

[EErkut]

Merhabalar,

örnek olması açısından basit bir çalışma gönderiyorum.
Sayın kulomer46 gönderdiğiniz örnekler için teşekkür ederim. Ancak satır sayısına göre işlem yapıyor. Benim istediğim satırda yazan adetlere göre toplama sonucuna göre işlem yapması.

 

[ÖmerFaruk]

Aşağıdaki kodları çalıştırdığınızda
1. satırı başlık satırı olarak her sayfada tekrarlar
Adet 600 ün üzerindeyse sayfa sonu ekler.
Önizlemeden görebilirsiniz.

Revize edilmiş hali.

Sub SayfaSonuEkle()
   Dim Sh As Worksheet, i As Long, Say As Long
   Set Sh = Worksheets("Ana Sayfa")
   MaxSat = 40 ' Olmasını istediğiniz maksimum satır sayısını girin
   Sh.ResetAllPageBreaks
   Sh.PageSetup.PrintTitleRows = "$1:$1"
   For i = 2 To Sh.Range("A" & Rows.Count).End(3).Row
      Say = Sh.Range("C" & i) + Say
      SatSay = SatSay + 1
      ' Toplam 600 olur ya da Saydaki satır sayısı maksimumdan büyük olursa
      'PageBreak koyar
      If Say > 600 Or SatSay > MaxSat Then
         Sh.HPageBreaks.Add before:=Sh.Range("A" & i)
         Say = 0: SatSay = 0: i = i - 1
      End If
   Next i
   Set Sh = Nothing
End Sub

 

[EErkut]

Sayın ÖmerFaruk,

Yapmış olduğunuz çalışma istediğim sonucu fazlasıyla karşılıyor.
Desteğinize ve emeğinize teşekkür ederim.

 

[ÖmerFaruk]

Eyvallah. Kolay gelsin.

 

[EErkut]

Merhaba ÖmerFaruk

Bu arada çalışmada şöyle bir hata ile karşılaştım. Adetler küçük olduğunda yani bir sayfaya 600 adet sığmadığında bölme işlemi hatalı oluyor. İlk bölme işlemi 173 adet oldu vs..

Bu hatayı nasıl düzeltebiliriz?

 

[ÖmerFaruk]

Bu ilave isteğinizi kodlara ekledim.
#5 nolu mesajdaki kodları yeniden deneyin.

 

[EErkut]

Ben kendi dokümanımı paylaşayım, dilerseniz üzerinde bakın çünkü ben sonuca ulaşamadım.

 

[ÖmerFaruk]

Sorun nerededir? Onu söyleseniz daha güzel olacak.
Verdiğim Kod ilk dosyanıza göre...sayfa adı Ana Sayfa
Şimdi dosyada Sayfa1 olmuş.

Şu iki satırı kendinize uyarlayın

Set Sh = Worksheets("Ana Sayfa") 'Hangi sayfayı istiyorsanız onun adını yazın.
MaxSat = 40 ' 600 olmadığı halde satırlar dolmuşsa sayfa sonu eklemek istediğiniz maksimum satır sayısını belirtin

 

[EErkut]

Günaydın ÖmerFaruk Bey,

Bu iki satırı uyarlamıştım. Problem sayfa sonlarındaki sayıların toplamı ilk sayfada 173 ikici sayfada 66 üçüncü sayfada 185 vs. şeklinde.

Gösterdiğiniz anlayış ve sabır için de ayrıca teşekkür ederim.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Add_PageBreaks()
    Dim S1 As Worksheet, X As Long, Total As Long
       
    Set S1 = Sheets("Ana Sayfa")
   
    S1.ResetAllPageBreaks

    For X = 3 To Cells(Rows.Count, 1).End(3).Row
        Total = Total + S1.Cells(X, "C")
        If Total > 600 Then
            S1.HPageBreaks.Add Before:=S1.Cells(X + 1, 1)
            Total = 0
        End If
    Next

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[EErkut]

Desteğiniz için teşekkür ederim Korhan Ayhan ama sonuç yine aynı çıkıyor bende, ilk sayfa 173 adet. Başka bir yöntem yapmak gerekir gibi düşünüyorum. Bu işlemin doğru sonucu göstermesi için 187. satırın sonuna sayfa sonu koyması gerekir. Sistemin çok satırlı olması sayfa sonu ekleme mantığına göre ters kalıyor sanki.
Sayfa sonu yerine belki boş satır eklenebilir. Ama bu kadar uğraştırdıktan sonra böyle bir şey isteyemem gibi düşünüyorum.

Teşekkür ederim hepinize...