Sayfaya yazdırılacak satır sayısını kısıtlamak.

[acolkesen1]

Merhaba arkadaşlar,
Ekteki dosyada b3:f500 arasında veri olan hücreleri, her sayafada 40 satır olacak şekilde yazdırmak istiyorum. Buna benzer bir çalışmaya daha önce forumda rastlamıştım, ancak tüm çabama rağmen bulamadım. Yardımcı olacak veya konuyla ilgili linki gönderecek arkadaşlara şimdiden teşekkür ederim.

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz, umarım doğru anlamışımdır.

Sub Makro1()
    Dim i As Long
    Dim SatırSayısı As Integer
    ActiveSheet.PageSetup.PrintArea = "$A$1:$F$" & [B65536].End(3).Row
    
    SatırSayısı = Application.InputBox("Satır Sayısını Belirtiniz", "Satır Sayısı Girişi", 40, Type:=1)
    If SatırSayısı = 0 Then SatırSayısı = 40
    
    ActiveSheet.ResetAllPageBreaks
    
    Application.ScreenUpdating = False
    
    For i = SatırSayısı + 3 To [B65536].End(3).Row Step SatırSayısı
        Range("A" & i).Select
        ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
    Next i
    
    Application.ScreenUpdating = True
    Range("G5").Activate
    
End Sub

 

[fedeal]

Altarnatif olsun,

Sub yaz()
For i = 2 To 482 Step 40
Range("B" & i & ":F" & i + 40).Select
    Selection.RowHeight = 21.5
ActiveSheet.PageSetup.PrintArea = "$B$" & i & ":$F$" & i + 39
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0.393700787401575)
        .BottomMargin = Application.InchesToPoints(0.393700787401575)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = True
        .CenterVertically = True
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperLegal
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 112
        .PrintErrors = xlPrintErrorsDisplayed
    End With
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Next
Cells(1, 1).Select
End Sub

 

[acolkesen1]

Merhaba Sayın Necdet Yeşertener ve Sayın fedeal,
İlginiz ve yardımlarınız için her ikinize de teşekkür ederim.
Sayın fedeal'in gönderdiği çalışmada makroda belirtilen alan tamamıyla dolu olmaması durumunda boş satırlar da sonuna kadar yazdırılıyor. Dolayısıyla gerekmeyen sayfalar da yazdırılmış oluyor. Sadece veri olan satırların yazdırılması gerekiyor oysa..Kodlarda bu yönde bir düzeltme yapılabilirseniz sevinirim.
Sayın Necdet Yeşertener'in kodları sadece veri olan son satıra kadar ve her sayfada 40 satır olacak şekilde sayfa sonlarını belirliyor ancak yazdırma komutu olmadığı için orda kalıyor. Sonuna eklediğim ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True koduyla yazdırma işini de hallettim. Ancak Sayın Yeşertener'den bir ricam olacak; acaba satır sayısını soran inputbox olmadan , yani yazdır komutu verildiğinde doğrudan sayfa sonlarını belirleyecek şekilde düzenleme yapabilir misiniz?Ben denedim ama olmadı..
İyi çalışmalar dilerim..

 

[acolkesen1]

Tekrar merhaba Sayın Yeşertener,
Kodlarınızı aşağıdaki şekilde değiştirerek sorunumu giderdim. İlginiz ve kodlarınız için çok teşekkür ederim. Esen kalın..

 

[parametre]

nasıl değiştirdiniz değişiklikten bahsetmişiniz ? benmi goremiyorum

 

[Necdet]

Merhaba,

Sub Makro1()
    Dim i As Long
    Dim SatırSayısı As Integer
    ActiveSheet.PageSetup.PrintArea = "$A$1:$F$" & [B65536].End(3).Row
    
    SatırSayısı = 40
    
    ActiveSheet.ResetAllPageBreaks
    
    Application.ScreenUpdating = False
    
    For i = SatırSayısı + 3 To [B65536].End(3).Row Step SatırSayısı
        Range("A" & i).Select
        ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
    Next i
    
    Application.ScreenUpdating = True
    Range("G5").Activate
    ActiveSheet.PrintPintout
End Sub

 

[acolkesen1]

Merhaba ,
5 nolu mesajımda Sayın Yeşertener'in kodlarında değişilik yaptığımdan sözettikten sonra kodları eklemeyi unutunca Sayın parametre haklı olarak göremediğini belirterek nasıl bir değişiklik yaptığımı sormuş. Kendisinden ve ilgilenen diğer arkadaşlardan özür dileyerek, yaptığım değişikliğin Sayın Yeşertener' in 7 no lu mesajındaki gibi olduğunu belirtmek isterim. Ayrıca Sayın Yeşertener'e de ilgisinden dolayı teşekkür eder iyi çalışmalar dilerim.
Esen kalın.

 

[Necdet]

İyi günlerde kullanınız.

Geri dönüşüm için de ayrıca teşekkür ederim.