• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Yazdırma düğmesi ve makrosu

Pegasus__

Pegasus__

Katılım
17 Şubat 2014
Mesajlar
49
Excel Vers. ve Dili
Microsoft 365 Tr 64 Bit
Merhaba arkadaşlar elimde 11 sayfalı bir çalışma kitabı var.

aşağıdaki şekilde bir makroya ihtiyaç duyuyorum.

ana sayfaya düğme ekleyerek sayfa4, sayfa5, sayfa6, sayfa7 (f20 ve AM40) hücreleri arasındaki alanda herhangi bir veri varsa ilgili sayfanın 2 kopya olarak yazdırılması, eğer veri yoksa ilgili sayfayı yazdırmayı pas geçmesi gerekmekte.

yani yukarıdaki sayfaların ilgili alanlarında veri varsa 2 kopya yazdırmasını istiyorum

(hepsinde aynı anda veri olmayabiliyor. hangisinde veri varsa onu yazdırsın)

(bu arada bahse konu alanda bulunan tüm hücrelerde formül bulunmakta fakat değerler farklı sayfalardan çekildiği için veri yoksa boş görünmektedir)

Teşekkür ederim
 
pegasus__' Alıntı:
Merhaba arkadaşlar elimde 11 sayfalı bir çalışma kitabı var.

aşağıdaki şekilde bir makroya ihtiyaç duyuyorum.

ana sayfaya düğme ekleyerek sayfa4, sayfa5, sayfa6, sayfa7 (f20 ve AM40) hücreleri arasındaki alanda herhangi bir veri varsa ilgili sayfanın 2 kopya olarak yazdırılması, eğer veri yoksa ilgili sayfayı yazdırmayı pas geçmesi gerekmekte.

yani yukarıdaki sayfaların ilgili alanlarında veri varsa 2 kopya yazdırmasını istiyorum

(hepsinde aynı anda veri olmayabiliyor. hangisinde veri varsa onu yazdırsın)

(bu arada bahse konu alanda bulunan tüm hücrelerde formül bulunmakta fakat değerler farklı sayfalardan çekildiği için veri yoksa boş görünmektedir)

Teşekkür ederim
Genişletmek için tıkla ...


Örnek dosya eklemenizde fayda var.
 
BedriA' Alıntı:
Örnek dosya eklemenizde fayda var.
Genişletmek için tıkla ...

Kod: 
Option Explicit
Sub sayfa_yazdır_61()
Dim ts, kaplan As Date, trabzonspor
trabzonspor = MsgBox("Sayfaları Yazdırıyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
kaplan = Time
For ts = 3 To Sheets.Count
If Sheets(ts).Name <> "Proje_1" And _
Sheets(ts).Name <> "Ders_ve_Etkinlik_1" And Sheets(ts). _
Name <> "Ders_ve_Etkinlik_2" And Sheets(ts).Name <> _
"Ders_ve_Etkinlik_3" Then
If Sheets(ts).Range("f20,am40") <> "" Then
Sheets(ts).PrintOut
End If
End If
Next
Application.ScreenUpdating = True
MsgBox Format(kaplan - Time, "hh:mm:ss") & vbLf _
& "Sürede İşlem Tamamlandı", , "Bitiş"
End Sub

Yukarıdaki kodu deniyorum ama boş olan son sayfayı boş olduğu halde çıkarıyor. Hata nerede acaba?

kod http://www.excel.web.tr/f14/tum-sayfalary-bazy-artlara-gore-yazdyrma-t105208.html

alıntıdır.

Teşekkürler!

edit:imla
 
Örnek dosya olunca bazen çözüm üretebiliyorum ama salt kod üzerinden yardımcı olacak kadar hakim değilim maalesef.
 
BedriA' Alıntı:
Örnek dosya olunca bazen çözüm üretebiliyorum ama salt kod üzerinden yardımcı olacak kadar hakim değilim maalesef.
Genişletmek için tıkla ...

çok özür dilerim

örnek dosya ile ilgili sıkıntı olduğu için gönderemiyorum affınıza sığınıyorum.

takıldığım yer şurası kaldı.

If Sheets(ts).Range("f20") <> " " Then

f20 den f40 nasıl kontrol ettiririm acaba. olacak gibi :)

gece gece çok zamanınızı almak istemem.
 
pegasus__' Alıntı:
çok özür dilerim

örnek dosya ile ilgili sıkıntı olduğu için gönderemiyorum affınıza sığınıyorum.

takıldığım yer şurası kaldı.

If Sheets(ts).Range("f20") <> " " Then

f20 den f40 nasıl kontrol ettiririm acaba. olacak gibi :)

gece gece çok zamanınızı almak istemem.
Genişletmek için tıkla ...


Dim... ile başlayan satırın hemen altına şu kodu yapıştırmayı deneyin.

Kod: 
If If Sheets(ts).Range("f20,am40") = "" Then
Msgbox "Sayfa boş", vbInformation, "        Bilgi"
End If
Exit Sub


Tam emin değilim ama olur umarım.
 
BedriA' Alıntı:
Dim... ile başlayan satırın hemen altına şu kodu yapıştırmayı deneyin.

Kod: 
If If Sheets(ts).Range("f20,am40") = "" Then
Msgbox "Sayfa boş", vbInformation, "        Bilgi"
End If
Exit Sub


Tam emin değilim ama olur umarım.
Genişletmek için tıkla ...

maalesef olumsuz

emeğiniz için binlerce teşekkür
 
Önceki kodda fazlalık vardı. Yine emin değilim ama bir deneyin.


Kod: 
If Sheets(ts).Range("f20,am40") = "" Then
Msgbox "Sayfa boş", vbInformation, "        Bilgi"
End If
Exit Sub
 
BedriA' Alıntı:
Önceki kodda fazlalık vardı. Yine emin değilim ama bir deneyin.


Kod: 
If Sheets(ts).Range("f20,am40") = "" Then
Msgbox "Sayfa boş", vbInformation, "        Bilgi"
End If
Exit Sub
Genişletmek için tıkla ...

birkaç farklı kombinasyonla denedim ama maalesef olmadı.


artık istediğim sayfları yazıyor fakat veri olsada olmasada yazıyor.

çözemedim maalesef

teşekkürler
 
Aşağıdaki kodu deneyiniz.

Kod: 
Option Explicit

Sub YAZDIR()
    Dim Sayfa As Worksheet, Sayfalar(), X As Byte, Say As Long
    Dim Kontrol_1 As Boolean, Kontrol_2 As Boolean, Veri As Range
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Sayfalar = Array("Proje1", "Etkinlik1", "Etkinlik2", "Etkinlik3")
    
    For Each Sayfa In ThisWorkbook.Worksheets
        For X = 0 To UBound(Sayfalar)
            If Sayfa.Name = Sayfalar(X) Then
                Kontrol_1 = True
                Exit For
            End If
        Next
        If Kontrol_1 = True Then
            For Each Veri In Sayfa.Range("F20:AM40")
                If Veri.Value <> "" Or Veri.Value > 0 Then
                    Kontrol_2 = True
                    Exit For
                End If
            Next
            If Kontrol_2 = True Then
                Sayfa.PrintOut , , 2
                Say = Say + 1
            End If
        End If
        Kontrol_1 = False
        Kontrol_2 = False
    Next
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    If Say > 0 Then
        MsgBox "Yazdırma işlemi tamamlanmıştır." & Chr(10) & "Yazdırılan sayfa sayısı ; " & Say, vbInformation
    Else
        MsgBox "Yazdırılıcak veri bulunamadı!", vbExclamation
    End If
End Sub
 
Korhan Ayhan' Alıntı:
Aşağıdaki kodu deneyiniz.

Kod: 
Option Explicit

Sub YAZDIR()
    Dim Sayfa As Worksheet, Sayfalar(), X As Byte, Say As Long
    Dim Kontrol_1 As Boolean, Kontrol_2 As Boolean, Veri As Range
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Sayfalar = Array("Sayfa4", "Sayfa5", "Sayfa6", "Sayfa7")
    
    For Each Sayfa In ThisWorkbook.Worksheets
        For X = 0 To UBound(Sayfalar)
            If Sayfa.Name = Sayfalar(X) Then
                Kontrol_1 = True
                Exit For
            End If
        Next
        If Kontrol_1 = True Then
            For Each Veri In Sayfa.Range("F20:AM40")
                If Veri.Value <> "" Or Veri.Value > 0 Then
                    Kontrol_2 = True
                    Exit For
                End If
            Next
            If Kontrol_2 = True Then
                Sayfa.PrintOut , , 2
                Say = Say + 1
            End If
        End If
    Next
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    If Say > 0 Then
        MsgBox "Yazdırma işlemi tamamlanmıştır." & Chr(10) & "Yazdırılan sayfa sayısı ; " & Say, vbInformation
    Else
        MsgBox "Yazdırılıcak veri bulunamadı!", vbExclamation
    End If
End Sub
Genişletmek için tıkla ...

Maalesef boş olsa da yazıyor.

Örnek dosyayı ekliyorum dün gönderememiştim. tekrar teşekkür ederim vakit ayırdığınız için
 

Ekli dosyalar

Son düzenleme:
Eklediğiniz dosyaya göre adı geçen sayfalarda veriler var. Yani hepsinin yazdırılması gerekiyor.

Üstteki mesajımda ki koda küçük bir ekleme yaptım. Tekrar deneyiniz.
 
Korhan Ayhan' Alıntı:
Eklediğiniz dosyaya göre adı geçen sayfalarda veriler var. Yani hepsinin yazdırılması gerekiyor.

Üstteki mesajımda ki koda küçük bir ekleme yaptım. Tekrar deneyiniz.
Genişletmek için tıkla ...

Öncelikle bayramınızı en içten dileklerimle kutlarım.

kodun son halini denedim fakat sayfalarda veri olsun yada olmasın 3. yazdırılan sayfada 400 hatası veriyor ve işlem kesiliyor.
hata metninde tamam tıklayınca Etkinlik1 sayfasını açıyor.

Teşekkür ederim
 
Merhaba,

Orjinal dosyanızda F20:AM40 hücre aralığında hata veren hücreler olabilir. Bunları kontrol edin. Bunun dışında kodu deneyerek foruma ekledim.

Dediğim gibi adı geçen sayfaların hepsinde veri var. Bu sebeple hepsi yazdırılıyor.
 
Korhan Ayhan' Alıntı:
Merhaba,

Orjinal dosyanızda F20:AM40 hücre aralığında hata veren hücreler olabilir. Bunları kontrol edin. Bunun dışında kodu deneyerek foruma ekledim.

Dediğim gibi adı geçen sayfaların hepsinde veri var. Bu sebeple hepsi yazdırılıyor.
Genişletmek için tıkla ...

Korhan Hocam

parametreyi yazdırmayı düşündüğüm sayfaların a58 hücrelerinde veri varsa yazdırsın yoksa yazdırmasın şeklinde değiştirirsek nasıl olur acaba?

a58 hücresi =topla(f40:am40) şeklinde formül içeriyor olacak
 
Son düzenleme:
Deneyiniz.

Kod: 
Option Explicit

Sub YAZDIR()
    Dim Sayfa As Worksheet, Sayfalar(), X As Byte, Say As Long
    Dim Kontrol_1 As Boolean, Kontrol_2 As Boolean
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Sayfalar = Array("Proje1", "Etkinlik1", "Etkinlik2", "Etkinlik3")
    
    For Each Sayfa In ThisWorkbook.Worksheets
        For X = 0 To UBound(Sayfalar)
            If Sayfa.Name = Sayfalar(X) Then
                Kontrol_1 = True
                Exit For
            End If
        Next
        If Kontrol_1 = True Then
            If Sayfa.Range("A58") <> 0 Then
                Kontrol_2 = True
            End If
            If Kontrol_2 = True Then
                Sayfa.PrintOut , , 2
                Say = Say + 1
            End If
        End If
        Kontrol_1 = False
        Kontrol_2 = False
    Next
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    If Say > 0 Then
        MsgBox "Yazdırma işlemi tamamlanmıştır." & Chr(10) & "Yazdırılan sayfa sayısı ; " & Say, vbInformation
    Else
        MsgBox "Yazdırılıcak veri bulunamadı!", vbExclamation
    End If
End Sub
 
Korhan Ayhan' Alıntı:
Deneyiniz.

Kod: 
Option Explicit

Sub YAZDIR()
    Dim Sayfa As Worksheet, Sayfalar(), X As Byte, Say As Long
    Dim Kontrol_1 As Boolean, Kontrol_2 As Boolean
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Sayfalar = Array("Proje1", "Etkinlik1", "Etkinlik2", "Etkinlik3")
    
    For Each Sayfa In ThisWorkbook.Worksheets
        For X = 0 To UBound(Sayfalar)
            If Sayfa.Name = Sayfalar(X) Then
                Kontrol_1 = True
                Exit For
            End If
        Next
        If Kontrol_1 = True Then
            If Sayfa.Range("A58") <> 0 Then
                Kontrol_2 = True
                Exit For
            End If
            If Kontrol_2 = True Then
                Sayfa.PrintOut , , 2
                Say = Say + 1
            End If
        End If
        Kontrol_1 = False
        Kontrol_2 = False
    Next
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    If Say > 0 Then
        MsgBox "Yazdırma işlemi tamamlanmıştır." & Chr(10) & "Yazdırılan sayfa sayısı ; " & Say, vbInformation
    Else
        MsgBox "Yazdırılıcak veri bulunamadı!", vbExclamation
    End If
End Sub
Genişletmek için tıkla ...

Yazdırılacak veri bulunamadı! demektedir.
 

Ekli dosyalar

Son düzenleme:
#16 nolu mesajımda ki kodu revize ettim. Tekrar deneyiniz.

Etkinlik3 sayfasında A58 hücresinde formül yok. Kontrol ediniz.
 
Korhan Ayhan' Alıntı:
#16 nolu mesajımda ki kodu revize ettim. Tekrar deneyiniz.

Etkinlik3 sayfasında A58 hücresinde formül yok. Kontrol ediniz.
Genişletmek için tıkla ...

Merhaba Korhan Hocam!

sayfalar makro tarafından yazdırılıyor elinize sağlık.

az önce bu mesajda olmadığına dair yazmıştım ama hatamı fark edince düzelttim. çok teşekkür ederim.

işlem tamamlanmıştır.

elinize sağlık
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst