Soru Veriye Göre Yazdır ve Ön İzle

H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
508
Excel Vers. ve Dili
2010, Türkiye
İyi günler;
Ekli dosyada iki adet buton var (Ön İzle ve Yazdır) . Yapmak istediğim
1- Yazdır ve Ön İzleme yaparken E13:E62 hücre aralığında dolu olan verilerdeki satırları yazdırma ve ön izleme yaptırırken boş satırlar gizlenecek yazdırılmayacak.
2-Eğer E13:E62 hücre aralığında tek cins veri varsa (Örneğin: Kayın Tomruk) B65:B77 satırları gizlenecek. Birden fazla cins varsa B65:B77 hücre aralığındaki dolu satırlarda ön izle ve yazdırma işlemi yapılacak. Destek olursanız sevinirim. Saygılarımla

Mutabakat_Tutanagi.xlsm dosyasını indir - download

Mutabakat_Tutanagi.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
www.dosya.tc www.dosya.tc
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
508
Excel Vers. ve Dili
2010, Türkiye
İyi akşamlar,
Ekli konuya destek olursanız sevinirim şimdiden teşekkürler
 
N

necati

Katılım
20 Şubat 2007
Mesajlar
675
Excel Vers. ve Dili
2007 Excel, Word Tr
Merhaba, Sayfada "N12" hücresine bir formül ile benzersiz sayısını aldırdıktan sonra kodu deneyiniz.
"N12" hücresindeki formül aşağıda. Adresi değiştirirseniz kod içindeki
If Range("N12").Value > 1 Then
Satırında da ayarlama yapınız.
=TOPLA.ÇARPIM((E13:E62<>"")/EĞERSAY(E13:E62;E13:E62&""))

Kod: 
Sub MUTABAKAT_ÖN_İZLE()
      
    On Error Resume Next
    Set syf = Sheets("MUTABAKAT TUTANAĞI")
    syf.PageSetup.PrintArea = ""
    ss1 = syf.Cells(Rows.Count, 2).End(xlUp).Row
    If ss1 < 13 Then ss1 = 13
    syf.Rows("13:" & ss1).EntireRow.Hidden = False
    ss2 = WorksheetFunction.Max(syf.Range("B13:B" & ss1)) + 15
    If ss2 < 13 Then Exit Sub
    syf.PageSetup.PrintArea = "B5:L" & ss1
    Range("b11:b62").AutoFilter 1, "<>", , , False
    
    If Range("N12").Value > 1 Then
        syf.PrintPreview
    Else
        Range("b65:b77").EntireRow.Hidden = True
        syf.PrintPreview
    End If
    
    If Range("b11:b62").Parent.AutoFilterMode Then Range("b11:b62").AutoFilter
    syf.Rows("13:" & ss1).EntireRow.Hidden = False
    syf.PageSetup.PrintArea = ""

End Sub
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
508
Excel Vers. ve Dili
2010, Türkiye
Neceti bey çok teşekkür ederim .Kod muhteşem. Koda ilave yapmanız mümkün mü.Şöyle ki;
Sarı renkli olarak işaretlediğim satırlarda da veri yoksa (Not:Formül var) bu satırlarıda ön izleme yaparken gizleyebilir mi ?

Mutabakat_Tutanagi.xlsm dosyasını indir - download

Mutabakat_Tutanagi.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
www.dosya.tc www.dosya.tc
 
N

necati

Katılım
20 Şubat 2007
Mesajlar
675
Excel Vers. ve Dili
2007 Excel, Word Tr
Kod: 
Sub MUTABAKAT_ÖN_İZLE()
     
    On Error Resume Next
    Set syf = Sheets("MUTABAKAT TUTANAĞI")
    syf.PageSetup.PrintArea = ""
    ss1 = syf.Cells(Rows.Count, 2).End(xlUp).Row
    If ss1 < 13 Then ss1 = 13
    syf.Rows("13:" & ss1).EntireRow.Hidden = False
    ss2 = WorksheetFunction.Max(syf.Range("B13:B" & ss1)) + 15
    If ss2 < 13 Then Exit Sub
    syf.PageSetup.PrintArea = "B5:L" & ss1
    Range("b11:b62").AutoFilter 1, "<>", , , False
   
    For Each Rng In Range("b65:b77")
        If Rng = "" Then
            If Check_Rng Is Nothing Then
                Set Check_Rng = Rng
            Else
                Set Check_Rng = Union(Check_Rng, Rng)
            End If
        End If
    Next
   
    If Range("N12").Value > 1 Then
        syf.Range(Check_Rng.Address).EntireRow.Hidden = True
        syf.PrintPreview
    Else
        Range("b65:b77").EntireRow.Hidden = True
        syf.PrintPreview
    End If
   
    If Range("b11:b62").Parent.AutoFilterMode Then Range("b11:b62").AutoFilter
    syf.Rows("13:" & ss1).EntireRow.Hidden = False
    syf.PageSetup.PrintArea = ""

End Sub
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
508
Excel Vers. ve Dili
2010, Türkiye
Neceti bey çok teşekkür ederim. Bu kodu aynı şekilde yazdır için uyarladım. Fakat yine ön izleme yapıyor. Bunu yazdır için nasıl yaparız?
Kod: 
Sub MUTABAKAT_YAZDIR()
    
    On Error Resume Next
    Set syf = Sheets("MUTABAKAT TUTANAĞI")
    syf.PageSetup.PrintArea = ""
    ss1 = syf.Cells(Rows.Count, 2).End(xlUp).Row
    If ss1 < 13 Then ss1 = 13
    syf.Rows("13:" & ss1).EntireRow.Hidden = False
    ss2 = WorksheetFunction.Max(syf.Range("B13:B" & ss1)) + 15
    If ss2 < 13 Then Exit Sub
    syf.PageSetup.PrintArea = "B5:L" & ss1
    Range("b11:b62").AutoFilter 1, "<>", , , False
  
    For Each Rng In Range("b65:b77")
        If Rng = "" Then
            If Check_Rng Is Nothing Then
                Set Check_Rng = Rng
            Else
                Set Check_Rng = Union(Check_Rng, Rng)
            End If
        End If
    Next
  
    If Range("N12").Value > 1 Then
        syf.Range(Check_Rng.Address).EntireRow.Hidden = True
        syf.PrintPreview
    Else
        Range("b65:b77").EntireRow.Hidden = True
         SayfaAdedi = Application.InputBox("LÜTFEN KOPYA SAYISINI GİRİNİZ ?", "KOPYA SAYISI GİRİŞİ !!!!", 2, Type:=2)
If Not SayfaAdedi = 0 Then Sheets("MUTABAKAT TUTANAĞI").PrintOut From:=1, To:=1, Copies:=2
    End If
  
    If Range("b11:b62").Parent.AutoFilterMode Then Range("b11:b62").AutoFilter
    syf.Rows("13:" & ss1).EntireRow.Hidden = False
    syf.PageSetup.PrintArea = ""

End Sub
 
N

necati

Katılım
20 Şubat 2007
Mesajlar
675
Excel Vers. ve Dili
2007 Excel, Word Tr
Kod: 
Sub MUTABAKAT_YAZDIR()
 
    On Error Resume Next
    Dim SayfaAdedi As Integer
    
    
    Set syf = Sheets("MUTABAKAT TUTANAĞI")
    syf.PageSetup.PrintArea = ""
    ss1 = syf.Cells(Rows.Count, 2).End(xlUp).Row
    If ss1 < 13 Then ss1 = 13
    syf.Rows("13:" & ss1).EntireRow.Hidden = False
    ss2 = WorksheetFunction.Max(syf.Range("B13:B" & ss1)) + 15
    If ss2 < 13 Then Exit Sub
    If ss1 - 9 > ss2 Then syf.Rows(ss2 + 1 & ":" & ss1 - 25).EntireRow.Hidden = True
    syf.PageSetup.PrintArea = "B5:L" & ss1
    Range("b11:b62").AutoFilter 1, "<>", , , False
 
    For Each Rng In Range("b65:b77")
        If Rng = "" Then
            If Check_Rng Is Nothing Then
                Set Check_Rng = Rng
            Else
                Set Check_Rng = Union(Check_Rng, Rng)
            End If
        End If
    Next
    
    If Range("N12").Value > 1 Then
    syf.Range(Check_Rng.Address).EntireRow.Hidden = True
    SayfaAdedi = Application.InputBox("LÜTFEN KOPYA SAYISINI GİRİNİZ ?", "KOPYA SAYISI GİRİŞİ !!!!", 2, Type:=2)
        If Not SayfaAdedi = 0 Then Sheets("MUTABAKAT TUTANAĞI").PrintOut From:=1, To:=1, Copies:=2
            Else
            Range("b65:b77").EntireRow.Hidden = True
            SayfaAdedi = Application.InputBox("LÜTFEN KOPYA SAYISINI GİRİNİZ ?", "KOPYA SAYISI GİRİŞİ !!!!", 2, Type:=2)
        If Not SayfaAdedi = 0 Then Sheets("MUTABAKAT TUTANAĞI").PrintOut From:=1, To:=1, Copies:=2
            End If
    
    If Range("b11:b62").Parent.AutoFilterMode Then Range("b11:b62").AutoFilter
    syf.Rows("13:" & ss1).EntireRow.Hidden = False
  
 
End Sub
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
508
Excel Vers. ve Dili
2010, Türkiye
Hocam teşekkür ederim. Şimdi farkına vardım Ön izle ve Yazdır yaparken E12 satırını gizliyor
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
508
Excel Vers. ve Dili
2010, Türkiye
Hocam çok teşekkür ederim. Emeğinize sağlık. Şurayı değiştirince düzeldi. İyi akşamlar
Range("B12:B62").AutoFilter 1, "<>", , , False
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
508
Excel Vers. ve Dili
2010, Türkiye
Necati bey merhabalar,
Şöyle bir sıkıntı var. Butonları farklı bir sayfaya aldığım zaman makro işlemiyor nerede düzenleme yapmamız gerekiyor.Yada makroyu revize edermisiniz
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
508
Excel Vers. ve Dili
2010, Türkiye
Necati bey yazdırma işleminde kutucuğa 1 adet çıktı yazmama rağmen 2 adet çıktı veriyor
 
N

necati

Katılım
20 Şubat 2007
Mesajlar
675
Excel Vers. ve Dili
2007 Excel, Word Tr
Hsn55' Alıntı:
Hocam teşekkür ederim. Şimdi farkına vardım Ön izle ve Yazdır yaparken E12 satırını gizliyor
Genişletmek için tıkla ...
Tekrar merhaba,
"E12" hücresinin gizlenmesi veya gösterilmesi makroya olumsuz bir etkisi yok. Ama yine de değiştirip istediğiniz hücreye alabilirsiniz.
Hsn55' Alıntı:
Necati bey merhabalar,
Şöyle bir sıkıntı var. Butonları farklı bir sayfaya aldığım zaman makro işlemiyor nerede düzenleme yapmamız gerekiyor.Yada makroyu revize edermisiniz
Genişletmek için tıkla ...
Makro içindeki alan belirttiğimiz yerlerin (Range) başına sayfa tanımını (syf) eklersek başka sayfalardan da erişilebilir.
Hsn55' Alıntı:
Necati bey yazdırma işleminde kutucuğa 1 adet çıktı yazmama rağmen 2 adet çıktı veriyor
Genişletmek için tıkla ...
Çıktı sayısını gösteren ifade
Copies:=2 dir. Bunu sabit olarak yazmışsınız. Copies:=SayfaAdedi şeklinde değiştirirsek inputbox ile girilen değer kadar sayfa yazdırır.
Buna göre revize edilen kodlar:
Kod: 
Sub MUTABAKAT_ÖN_İZLE()
    
    On Error Resume Next
    Set syf = Sheets("MUTABAKAT TUTANAĞI")
    syf.PageSetup.PrintArea = ""
    ss1 = syf.Cells(Rows.Count, 2).End(xlUp).Row
    If ss1 < 13 Then ss1 = 13
    syf.Rows("13:" & ss1).EntireRow.Hidden = False
    ss2 = WorksheetFunction.Max(syf.Range("B13:B" & ss1)) + 15
    If ss2 < 13 Then Exit Sub
    syf.PageSetup.PrintArea = "B5:L" & ss1
    syf.Range("b12:b62").AutoFilter 1, "<>", , , False
  
    For Each Rng In syf.Range("b65:b77")
        If Rng = "" Then
            If Check_Rng Is Nothing Then
                Set Check_Rng = Rng
            Else
                Set Check_Rng = Union(Check_Rng, Rng)
            End If
        End If
    Next
  
    If syf.Range("N12").Value > 1 Then
        syf.Range(Check_Rng.Address).EntireRow.Hidden = True        'sh.PrintOut
        syf.PrintPreview
    Else
        syf.Range("b65:b77").EntireRow.Hidden = True
        syf.PrintPreview
    End If
  
    If syf.Range("b12:b62").Parent.AutoFilterMode Then syf.Range("b12:b62").AutoFilter
    syf.Rows("13:" & ss1).EntireRow.Hidden = False
    syf.PageSetup.PrintArea = ""

End Sub

Sub MUTABAKAT_YAZDIR()

    On Error Resume Next
    Dim SayfaAdedi As Integer
  
    Set syf = Sheets("MUTABAKAT TUTANAĞI")
    syf.PageSetup.PrintArea = ""
    ss1 = syf.Cells(Rows.Count, 2).End(xlUp).Row
    If ss1 < 13 Then ss1 = 13
    syf.Rows("13:" & ss1).EntireRow.Hidden = False
    ss2 = WorksheetFunction.Max(syf.Range("B13:B" & ss1)) + 15
    If ss2 < 13 Then Exit Sub
    If ss1 - 9 > ss2 Then syf.Rows(ss2 + 1 & ":" & ss1 - 25).EntireRow.Hidden = True
    syf.PageSetup.PrintArea = "B5:L" & ss1
    syf.Range("b12:b62").AutoFilter 1, "<>", , , False

    For Each Rng In syf.Range("b65:b77")
        If Rng = "" Then
            If Check_Rng Is Nothing Then
                Set Check_Rng = Rng
            Else
                Set Check_Rng = Union(Check_Rng, Rng)
            End If
        End If
    Next
  
    If syf.Range("N12").Value > 1 Then
        syf.Range(Check_Rng.Address).EntireRow.Hidden = True
        SayfaAdedi = Application.InputBox("LÜTFEN KOPYA SAYISINI GİRİNİZ ?", "KOPYA SAYISI GİRİŞİ !!!!", 2, Type:=2)
        If Not SayfaAdedi = 0 Then Sheets("MUTABAKAT TUTANAĞI").PrintOut From:=1, To:=1, Copies:=SayfaAdedi
    Else
        syf.Range("b65:b77").EntireRow.Hidden = True
        SayfaAdedi = Application.InputBox("LÜTFEN KOPYA SAYISINI GİRİNİZ ?", "KOPYA SAYISI GİRİŞİ !!!!", 2, Type:=2)
        If Not SayfaAdedi = 0 Then Sheets("MUTABAKAT TUTANAĞI").PrintOut From:=1, To:=1, Copies:=SayfaAdedi
    End If
  
    If syf.Range("b12:b62").Parent.AutoFilterMode Then syf.Range("b12:b62").AutoFilter
    syf.Rows("13:" & ss1).EntireRow.Hidden = False

End Sub
 
Son düzenleme:
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
508
Excel Vers. ve Dili
2010, Türkiye
necati' Alıntı:
Tekrar merhaba,
"E12" hücresinin gizlenmesi veya gösterilmesi makroya olumsuz bir etkisi yok. Ama yine de değiştirip istediğiniz hücreye alabilirsiniz.

Makro içindeki alan belirttiğimiz yerlerin (Range) başına sayfa tanımını (syf) eklersek başka sayfalardan da erişilebilir.

Çıktı sayısını gösteren ifade
Copies:=2 dir. Bunu sabit olarak yazmışsınız. Copies:=SayfaAdedi şeklinde değiştirirsek inputbox ile girilen değer kadar sayfa yazdırır.
Buna göre revize edilen kodlar:
Kod: 
Sub MUTABAKAT_ÖN_İZLE()
   
    On Error Resume Next
    Set syf = Sheets("MUTABAKAT TUTANAĞI")
    syf.PageSetup.PrintArea = ""
    ss1 = syf.Cells(Rows.Count, 2).End(xlUp).Row
    If ss1 < 13 Then ss1 = 13
    syf.Rows("13:" & ss1).EntireRow.Hidden = False
    ss2 = WorksheetFunction.Max(syf.Range("B13:B" & ss1)) + 15
    If ss2 < 13 Then Exit Sub
    syf.PageSetup.PrintArea = "B5:L" & ss1
    syf.Range("b12:b62").AutoFilter 1, "<>", , , False
 
    For Each Rng In syf.Range("b65:b77")
        If Rng = "" Then
            If Check_Rng Is Nothing Then
                Set Check_Rng = Rng
            Else
                Set Check_Rng = Union(Check_Rng, Rng)
            End If
        End If
    Next
 
    If syf.Range("N12").Value > 1 Then
        syf.Range(Check_Rng.Address).EntireRow.Hidden = True        'sh.PrintOut
        syf.PrintPreview
    Else
        syf.Range("b65:b77").EntireRow.Hidden = True
        syf.PrintPreview
    End If
 
    If syf.Range("b12:b62").Parent.AutoFilterMode Then syf.Range("b12:b62").AutoFilter
    syf.Rows("13:" & ss1).EntireRow.Hidden = False
    syf.PageSetup.PrintArea = ""

End Sub

Sub MUTABAKAT_YAZDIR()

    On Error Resume Next
    Dim SayfaAdedi As Integer
 
    Set syf = Sheets("MUTABAKAT TUTANAĞI")
    syf.PageSetup.PrintArea = ""
    ss1 = syf.Cells(Rows.Count, 2).End(xlUp).Row
    If ss1 < 13 Then ss1 = 13
    syf.Rows("13:" & ss1).EntireRow.Hidden = False
    ss2 = WorksheetFunction.Max(syf.Range("B13:B" & ss1)) + 15
    If ss2 < 13 Then Exit Sub
    If ss1 - 9 > ss2 Then syf.Rows(ss2 + 1 & ":" & ss1 - 25).EntireRow.Hidden = True
    syf.PageSetup.PrintArea = "B5:L" & ss1
    syf.Range("b12:b62").AutoFilter 1, "<>", , , False

    For Each Rng In syf.Range("b65:b77")
        If Rng = "" Then
            If Check_Rng Is Nothing Then
                Set Check_Rng = Rng
            Else
                Set Check_Rng = Union(Check_Rng, Rng)
            End If
        End If
    Next
 
    If syf.Range("N12").Value > 1 Then
        syf.Range(Check_Rng.Address).EntireRow.Hidden = True
        SayfaAdedi = Application.InputBox("LÜTFEN KOPYA SAYISINI GİRİNİZ ?", "KOPYA SAYISI GİRİŞİ !!!!", 2, Type:=2)
        If Not SayfaAdedi = 0 Then Sheets("MUTABAKAT TUTANAĞI").PrintOut From:=1, To:=1, Copies:=SayfaAdedi
    Else
        syf.Range("b65:b77").EntireRow.Hidden = True
        SayfaAdedi = Application.InputBox("LÜTFEN KOPYA SAYISINI GİRİNİZ ?", "KOPYA SAYISI GİRİŞİ !!!!", 2, Type:=2)
        If Not SayfaAdedi = 0 Then Sheets("MUTABAKAT TUTANAĞI").PrintOut From:=1, To:=1, Copies:=SayfaAdedi
    End If
 
    If syf.Range("b12:b62").Parent.AutoFilterMode Then syf.Range("b12:b62").AutoFilter
    syf.Rows("13:" & ss1).EntireRow.Hidden = False

End Sub
Genişletmek için tıkla ...
Necati bey çok teşekkür ederim
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst