Şarta göre her 30 satırda bir yazdırma

[meleklerim]

arkadaşlar
elimde rapor almada kullandığım bir form var. bu form düşeyara formülleri ile dolu. Ve rapor bazen 100 sayfayı buluyor. haliyle bu kadar çok formüllü sayfa exceli yavaşlatıyor. Şöyle bir fikrim var. Bunu makro ile yapabilrisek sadece 1 sayfa rapor şablonu ile bu işi halledebiliriz. Şablon ektedir.
Yardımcı olacak arkadaşlara şimdiden teşekkürler


A4 Hücresinde 1'Den Başlayarak A33 Hücresine Kadar Birer Birer Arttırarak
J2 Hücresindeki Sayıya Kadar (örnğin 265) Sayı Vermesini İstiyorum
Ancak Sayfada 30 Satırlık Kayıt Olduğundan Her 30 Satırda Bir Sayfayı Yazdırıp
Tekrar Kaldığı Yerden A4 Hücresine 31, 61, 91, 121…. Yazarak Devam Etmesini İstiyorum.
Sayfanın Sonundaki H34 Hücresindeki Veriyi H3 Hücresine Kopyalarak (Formülü Değil, Veriyi) J2 Hücresindeki Sayıya Ulaşana Dek Devam Etmesini İstiyorum.

Formülü Sözele Dökersek
a sütuna a4-a33 arasına 1 Den Başla 30 A Kadar Doldur
Yazdır

a sütuna a4-a33 arasına 31 Den Başla 60 Kadar Doldur
H34 Hücresini H3 Hücresine Kopyala
Yazdır
a sütuna a4-a33 arasına 61 Den Başla 90 Kadar Doldur
H34 Hücresini H3 Hücresine Kopyala
Yazdır

265 Olana Dek Devam Et

 

[pitchoute]

Merhabalar, hücre numaralarını kontrolünü sağlayarak ve mümkünse dosyanızın yedeğini alarak deneyip sonucu paylaşabilir misiniz;

Sub RaporYazdir()

    Dim toplamSayi As Long
    Dim baslangicSayi As Long
    Dim i As Long
    Dim satirNo As Long
    Dim s As Worksheet
    Dim sayfaNo As Long

    Application.ScreenUpdating = False

    Set s = ThisWorkbook.Sheets("Rapor") ' Şablon sayfanızın adı

    toplamSayi = s.Range("J2").Value
    baslangicSayi = 1
    sayfaNo = 1

    Do While baslangicSayi <= toplamSayi

        s.Range("A4:A33").ClearContents

        For i = 4 To 33
            satirNo = baslangicSayi + (i - 4)
            If satirNo <= toplamSayi Then
                s.Cells(i, "A").Value = satirNo
            Else
                Exit For
            End If
        Next i

        s.Range("H3").Value = s.Range("H34").Value

        Application.StatusBar = "Sayfa " & sayfaNo & " yazdırılıyor..."

        ' s.PrintPreview ' Eğer önizleme yapmak isterseniz bu satırı etkinleştirin
        s.PrintOut

        baslangicSayi = baslangicSayi + 30
        sayfaNo = sayfaNo + 1

    Loop

    Application.StatusBar = False

    Application.ScreenUpdating = True

    MsgBox "Rapor yazdırma işlemi tamamlandı.", vbInformation

End Sub

 

[meleklerim]

teşekkür ederim. şimdi deneme fırsatı buldum. ufak bir hatası var
s.Range("H3").Value = s.Range("H34").Value
bu işlemi yazdırmadan önce yaptığı için toplamları hatalı (fazla) çıkıyor.
kopyalayıp yapıştırmadan önce sayfayı yazdırması
daha sonra sonraki sayfaya geçince
önceki sayfanın değerini yapıştırması gerekiyor.
ve bu kopyala yapıştır işlemini ilk sayfada yapmaması gerekiyor.
selamlar

 

[pitchoute]

Merhaba, yazma işlemi yaptıktan sonra işlemin yapılması şekilde düzenledim hocam, şu şekilde dener misiniz;

Sub RaporYazdir()

    Dim toplamSayi As Long
    Dim baslangicSayi As Long
    Dim i As Long
    Dim satirNo As Long
    Dim s As Worksheet
    Dim sayfaNo As Long

    Application.ScreenUpdating = False

    Set s = ThisWorkbook.Sheets("Rapor")

    toplamSayi = s.Range("J2").Value
    baslangicSayi = 1
    sayfaNo = 1

    Do While baslangicSayi <= toplamSayi

        s.Range("A4:A33").ClearContents

        For i = 4 To 33
            satirNo = baslangicSayi + (i - 4)
            If satirNo <= toplamSayi Then
                s.Cells(i, "A").Value = satirNo
            Else
                Exit For
            End If
        Next i

        Application.StatusBar = "Sayfa " & sayfaNo & " yazdırılıyor..."

        ' Yazdırma işlemi
        ' s.PrintPreview ' Eğer önizleme yapmak isterseniz bu satırı etkinleştirin
        s.PrintOut

        s.Range("H3").Value = s.Range("H34").Value

        baslangicSayi = baslangicSayi + 30
        sayfaNo = sayfaNo + 1

    Loop

    Application.StatusBar = False

    Application.ScreenUpdating = True

    MsgBox "Rapor yazdırma işlemi tamamlandı.", vbInformation

End Sub

 

[meleklerim]

çok teşekkür ederim oldu.

 

[pitchoute]

Rica ederim, iyi çalışmalar