Buton ile Yazdırma alanına Sayfa ekleme

pckatil

Altın Üye
Katılım
24 Ocak 2008
Mesajlar
20
Beğeniler
0
Excel Vers. ve Dili
2003
#1
Merhaba Arkadaşlar;

Çalıştığım excelde buton bastığımda sayfa2 nin aynısını eklemesini istiyorum. Bu sayfalar 2 3 4 şeklinde her bastığımda bir sonraki sayfanın altına ekletmem mümkünmüdür?

Çalışma kitabını ek olarak ekliyorum.

Şimdiden teşekkürler.
 

Ekli dosyalar

Korhan Ayhan

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
24,543
Beğeniler
373
Excel Vers. ve Dili
OFFICE 2019 PRO TR
#3
Deneyiniz.

Kod:
Option Explicit

Sub Yazdirma_Alanina_Sayfa_ekle()
    Dim Bul As Range, Adres As String, Say As Integer
    
    Rows("51:100").Copy Cells(Rows.Count, 1).End(3)(46, 1)
    ActiveSheet.PageSetup.PrintArea = "$A:$Y"
    With ActiveSheet.PageSetup
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1000
    End With
    ActiveSheet.ResetAllPageBreaks
    Set Bul = Cells.Find("HUB", , , xlWhole)
    If Not Bul Is Nothing Then
        Adres = Bul.Address
        Do
            Say = Say + 1
            Set ActiveSheet.HPageBreaks(Say).Location = Bul.Offset(-1, 0)
            Set Bul = Cells.FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If

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

pckatil

Altın Üye
Katılım
24 Ocak 2008
Mesajlar
20
Beğeniler
0
Excel Vers. ve Dili
2003
#4
Kod için çok teşekkür ederim. Çok işime yaradı. Sadece yeni sayfa ekle dediğimde sayfanın sağ tarafında 2 adet butonum var onlarıda ekliyor. Bunu düzeltebilirmiyim ve o iki butonu sayfa ile birlikte aşağı yukarı hareketini sağlıyabilirmiyim? bide bu iki butonu pencere içine almak istiyorum. Ayrı bir program havasında.
 

Ekli dosyalar

Korhan Ayhan

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
24,543
Beğeniler
373
Excel Vers. ve Dili
OFFICE 2019 PRO TR
#5
Sayfadaki butonlarınızı bir Userform üzerine ekleyip kullanırsanız istediğiniz sonuca ulaşabilirsiniz.

Forumda userform örnekleri bolca var.
 

pckatil

Altın Üye
Katılım
24 Ocak 2008
Mesajlar
20
Beğeniler
0
Excel Vers. ve Dili
2003
#6
Kod için tekrar teşekkür ederim. Sizin verdiğiniz şekilde kodları uyguladım. Buton sabitleme işlemini bölüm dondurma ile çözdüm gibi ama sayfa ekle butonuna bastığımda sayfa ekliyor lakin ilk satırdaki dondurulmuş alanıda yazdırma alanının içine alıyor ve ilk sayfadaki yazdırma alanı bir satır yukarı kayıyor. Bunu nasıl düzeltebilirim. Birde yeni sayfa ekle dediğimde sayfa 2 ye eklediğim resimleride yeni sayfaya ekliyor sadece hücre biçimini ekletme şansım varmı?
 

Ekli dosyalar

Korhan Ayhan

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
24,543
Beğeniler
373
Excel Vers. ve Dili
OFFICE 2019 PRO TR
#7
Deneyiniz.

Kod:
Option Explicit

Sub Yazdirma_Alanina_Sayfa_ekle()
    Dim Bul As Range, Adres As String, Say As Integer, Alan As Range, Nesne As Object
    
    Rows("52:101").Copy Cells(Rows.Count, 1).End(3)(46, 1)
    
    Set Alan = Cells(Rows.Count, 1).End(3).Resize(44, 25)
    
    For Each Nesne In ActiveSheet.DrawingObjects
        If Not Intersect(Alan, Range(Nesne.TopLeftCell, Nesne.BottomRightCell)) Is Nothing Then
            Nesne.Delete
        End If
    Next
    
    ActiveSheet.PageSetup.PrintArea = "$A$2:$Y$" & Cells(Rows.Count, 1).End(3)(44, 1).Row
    With ActiveSheet.PageSetup
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1000
    End With
    ActiveSheet.ResetAllPageBreaks
    Set Bul = Cells.Find("HUB", , , xlWhole)
    If Not Bul Is Nothing Then
        Adres = Bul.Address
        Do
            Say = Say + 1
            Set ActiveSheet.HPageBreaks(Say).Location = Bul.Offset(-1, 0)
            Set Bul = Cells.FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If

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

Korhan Ayhan

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
24,543
Beğeniler
373
Excel Vers. ve Dili
OFFICE 2019 PRO TR
#9
Deneyiniz.

Kod:
Sub Yazdirma_Alanindaki_Son_Sayfayi_Sil()
    Dim X As Long, Y As Long
    X = ActiveSheet.HPageBreaks(ActiveSheet.HPageBreaks.Count).Location.Row
    Y = X + 48
    Range("A" & X & ":A" & Y).EntireRow.Delete
End Sub
 
Üst