Belirli Bir Yazdırma Alanı İçerisinde Yazdırma İşlemi

[GLMNYX]

Excelde bir çalışma sayfası içerisinde 25 adet alt alta sıralı yazdırma alanı ile belirlenmiş sayfa vardır. Çalışma Sayfasını yazdır dediğimde 25 adet sayfa yazdırılıyor. Bazen bu 25 sayfa içerisinde yazdırmak istemediğim sayfalar oluyor. Bu sayfaların belirlenmesinde sayfa içerisinde belirli hücrelerin dolu veya boş olmasına göre yazdırmaya dahil olması veya olmamasını istiyorum. Örneğin 7. sayfada B155 hücresi boş ise 7. sayfayı yazdırma, 13. sayfada C248 hücresi boş ise onu yazdırma. Her sayfa belli hücreler atıyarak toplam 25. hücre belirleyip hücreler dolu ise yazdırsın boş ise sayfayı yazdırmasın. Bu işlemler için neler yapmam gerekiyor?

 

[Muzaffer Ali]

Merhaba.

Excelde Worddeki gibi özel yazdır seçeneği yok.
Sorunuzu şöyle çözebiliriz;

Aşağıdaki kod "B155" hücresi doluysa "A10:L120" aralığını yazdırır
"C248" hücresi doluysa "A290:L320" aralığını yazdırır.

Sub Test()
    If Range("B155") <> "" Then Range("A10:L120").PrintOut
    If Range("C248") <> "" Then Range("A290:L320").PrintOut
End Sub

Bu mantık ile diğer sayfaları da koda ilave ederek denetimli yazdırabilirsiniz.

 

[GLMNYX]

teşekkür ederim deneyeyim hemen, kısaca yaptığım işide anlatayım çözümleme açısından ben lab. uzmanıyım farklı kategorilerde deneyler yapıyorum. her deney için bir form sistemim var. Bir çalışma sayfası içerisinde 25 adet aynı özellikte deney formu var ve bunun gibi 10 çalışma sayfası mevcut her 10 çalışma sayfasındada 25 adet form var alt alta sıraladım. yazdır komutu verince 250 sayfa yazıcıya gidiyor fakat bu 250 sayfa içerisinde yazdırmak istemediğim sayfalar var. Bu sayfaların tayini içinde belli hücrelerin içinin dolu veya boş olmasına göre yazdırmak istiyorum. Hücre boş ise ilgili sayfayı yazdırmasın, dolu ise yazdırsın.

 

[Muzaffer Ali]

Aşağıdaki kod "B155" hücresi doluysa 1. sayfayı yazdırır
"C248" hücresi doluysa 2. sayfayı yazdırır.
Bu şekilde diğer sayfaları da altına ekleyerek yazdırabilirsiniz.

Sub Test()
    If Range("B155") <> "" Then ActiveSheet.PrintOut From:=1, To:=1
    If Range("C248") <> "" Then ActiveSheet.PrintOut From:=2, To:=2

End Sub

 

[GLMNYX]

çok teşekkür ederim

 

[GLMNYX]

tekrardan merhabalar elinize sağlık bu kodları uygulamadım oldu fakat her sayfa için ayrı bir buton oluşturdum. 8 tane buton oluştu bütün makroları nasıl birleştirebilirim tek bir buton haline getirmek istiyorum

 

[GLMNYX]

birde activesheet yani aktif olan sayfayı değilde istediğim bir sayfadaki değerleri çalışmak istediğimde activesheet yerine ne yazmalıyım?

 

[Muzaffer Ali]

Aşağıdaki kod Sayfa1'in "B155" hücresi doluysa Sayfa1'in 1. sayfasını yazdırır1. sayfayı yazdırır
Sayfa2'nin"C248" hücresi doluysa Sayfa2'nin 2. sayfasını yazdırır.

Sub Test()
    If worksheets("Sayfa1").Range("B155") <> "" Then worksheets("Sayfa1").PrintOut From:=1, To:=1
    If worksheets("Sayfa2")Range("C248") <> "" Then worksheets("Sayfa2").PrintOut From:=2, To:=2

End Sub

 

[GLMNYX]

çok teşekkür ederim, Ben bu şekilde yaptım dediğim gibi 8 makro oldu her sayfa için, aynı anda hepsinin çalışması için ne yapmalıyım? ikinci olarakda çıktı olarak pdf almak istiyorum, zira direk yazıcıya gönderiyor kontrol amaçlı önce pdf yapmam lazım.

 

[Muzaffer Ali]

Kodları paylaşın birleştirelim.

 

[GLMNYX]

Sub Test()
If worksheets("Sayfa1").Range("B155") <> "" Then worksheets("Sayfa1").PrintOut From:=1, To:=1
If worksheets("Sayfa2")Range("C248") <> "" Then worksheets("Sayfa2").PrintOut From:=2, To:=2

End Sub


teşekkür ederim bu kodlara göre uygulayınca birleştirmeye gerek kalmadı zaten birleştirilmiş gibi oldu sağolun. Peki yazıcı değilde PDF çıktısı olarak nasıl bir uygulama yapabilirim, zira çıktı almadan önce pdf almam gerekiyor ön inceleme yapmak için

 

[Muzaffer Ali]

"PDF_Yazdir" kodlarını çalıştırdığınızda pdf yazdırır
"Yazdir" kodlarını çalıştırdığınızda aktif yazıcıdan yazdırır.

Sub PDF_Yazdir()
    Dim Yazicilar As Object
    Dim Yazici As Object
    Dim AktifYazici As String
    AktifYazici = Application.ActivePrinter
    Set Yazicilar = GetObject("winmgmts:\\.\root\cimv2").ExecQuery("Select * From Win32_Printer")
    For Each Yazici In Yazicilar
        If Yazici.Name Like "*PDF*" Then
            Application.ActivePrinter = Yazici.Name
            Yazdir
            Application.ActivePrinter = AktifYazici
            Exit Sub
        End If
    Next
End Sub

Sub Yazdir()
    If Worksheets("Sayfa1").Range("B155") <> "" Then Worksheets("Sayfa1").PrintOut From:=1, To:=1
    If Worksheets("Sayfa2").Range("C248") <> "" Then Worksheets("Sayfa2").PrintOut From:=2, To:=2
End Sub

 

[GLMNYX]

PDF çıktı almasınını beceremedim, birşeyleri eksik yapıyorum yazdığım kodların üstüne sizin paylaştığınız pdf kodunu ekliyorum araya düz bir çizgi atıyor sonra kodu çalıştırdığımda hata veriyor.

 

[necati]

PDF çıktı almasınını beceremedim, birşeyleri eksik yapıyorum yazdığım kodların üstüne sizin paylaştığınız pdf kodunu ekliyorum araya düz bir çizgi atıyor sonra kodu çalıştırdığımda hata veriyor.

Örnek dosya paylaşabilirseniz daha verimli sonuç alabilirsiniz.
İstediğiniz yazıcıdan kağıt olarak çıktı almak mı, bilgisayarınıza pdf dosyası şeklinde kayıt edilmesi mi? Kaydetmek, yazıcıyı değiştirmenin dezavantajlarından kurtulmanın kestirme yoludur.

 

[GLMNYX]

Sub Test()
If Worksheets("Ö").Range("C5") <> "" Then Worksheets("Ö").PrintOut From:=1, To:=1
If Worksheets("Sİ").Range("A12") <> "" Then Worksheets("Sİ").PrintOut From:=1, To:=1
If Worksheets("EA").Range("B8") <> "" Then Worksheets("EA").PrintOut From:=1, To:=1
If Worksheets("EA").Range("B54") <> "" Then Worksheets("EA").PrintOut From:=2, To:=2
If Worksheets("EA").Range("B100") <> "" Then Worksheets("EA").PrintOut From:=3, To:=3
If Worksheets("EA").Range("B146") <> "" Then Worksheets("EA").PrintOut From:=4, To:=4
If Worksheets("EA").Range("B192") <> "" Then Worksheets("EA").PrintOut From:=5, To:=5
If Worksheets("EA").Range("B238") <> "" Then Worksheets("EA").PrintOut From:=6, To:=6
If Worksheets("EA").Range("B284") <> "" Then Worksheets("EA").PrintOut From:=7, To:=7
If Worksheets("EA").Range("B330") <> "" Then Worksheets("EA").PrintOut From:=8, To:=8
If Worksheets("EA").Range("B376") <> "" Then Worksheets("EA").PrintOut From:=9, To:=9
If Worksheets("EA").Range("B422") <> "" Then Worksheets("EA").PrintOut From:=10, To:=10
If Worksheets("EA").Range("B468") <> "" Then Worksheets("EA").PrintOut From:=11, To:=11
If Worksheets("EA").Range("B514") <> "" Then Worksheets("EA").PrintOut From:=12, To:=12
If Worksheets("K").Range("B8") <> "" Then Worksheets("K").PrintOut From:=1, To:=1
If Worksheets("K").Range("B48") <> "" Then Worksheets("K").PrintOut From:=2, To:=2
If Worksheets("K").Range("B88") <> "" Then Worksheets("K").PrintOut From:=3, To:=3
If Worksheets("K").Range("B128") <> "" Then Worksheets("K").PrintOut From:=4, To:=4
If Worksheets("K").Range("B168") <> "" Then Worksheets("K").PrintOut From:=5, To:=5
If Worksheets("K").Range("B208") <> "" Then Worksheets("K").PrintOut From:=6, To:=6
If Worksheets("K").Range("B248") <> "" Then Worksheets("K").PrintOut From:=7, To:=7
If Worksheets("K").Range("B288") <> "" Then Worksheets("K").PrintOut From:=8, To:=8
If Worksheets("K").Range("B328") <> "" Then Worksheets("K").PrintOut From:=9, To:=9
If Worksheets("K").Range("B368") <> "" Then Worksheets("K").PrintOut From:=10, To:=10
If Worksheets("K").Range("B408") <> "" Then Worksheets("K").PrintOut From:=11, To:=11
If Worksheets("K").Range("B448") <> "" Then Worksheets("K").PrintOut From:=12, To:=12
If Worksheets("DK").Range("B8") <> "" Then Worksheets("DK").PrintOut From:=1, To:=1
If Worksheets("DK").Range("B56") <> "" Then Worksheets("DK").PrintOut From:=2, To:=2
If Worksheets("DK").Range("B104") <> "" Then Worksheets("DK").PrintOut From:=3, To:=3
If Worksheets("DK").Range("B152") <> "" Then Worksheets("DK").PrintOut From:=4, To:=4
If Worksheets("DK").Range("B200") <> "" Then Worksheets("DK").PrintOut From:=5, To:=5
If Worksheets("DK").Range("B248") <> "" Then Worksheets("DK").PrintOut From:=6, To:=6
If Worksheets("DK").Range("B296") <> "" Then Worksheets("DK").PrintOut From:=7, To:=7
If Worksheets("DK").Range("B344") <> "" Then Worksheets("DK").PrintOut From:=8, To:=8
If Worksheets("DK").Range("B392") <> "" Then Worksheets("DK").PrintOut From:=9, To:=9
If Worksheets("DK").Range("B440") <> "" Then Worksheets("DK").PrintOut From:=10, To:=10
If Worksheets("DK").Range("B488") <> "" Then Worksheets("DK").PrintOut From:=11, To:=11
If Worksheets("DK").Range("B536") <> "" Then Worksheets("DK").PrintOut From:=12, To:=12

End Sub

böyle bir çalışma kodu oluşturdum, Ö Sayfası bir sayfa, Si Sayfası bir sayfa, EA,K ve DK sayfaları kendi içinde 12 sayfadan oluşuyor. Bunlar deney formları, EA,K ve DK içerisinde belli hücrelerin dolu ve dolu olmaması durumunda yazdırma işlemi yapıyorum. Benim istediğim Bütün bu sayfalarının PDF çıktısı olması yani dediğiniz gibi bilgisayarıma kaydetmek istiyorum. Sonra kontrol edip yazıcıya pdf den yollayabilirim

 

[GLMNYX]

örneğin tüm sayfalarım dolu olduğunu düşünürsek 38 Sayfalık tek bir parça PDF dosyasını bilgisayarıma kaydetmek istiyorum

 

[necati]

Bu makro ile excel dosyası ile aynı klasör içinde "Kontrol.pdf" adlı dosya oluşur.

Sub Yazdirma_alanlarini_Kaydet()
Dim ws As Worksheet, i As Integer, j As Integer
Dim myrange As Variant, sayfa As Integer, ss As Long
Dim ust As Range, alt As Range, rng As String, unirng As String

Set ws = ActiveSheet

For Each ws In Worksheets
    Set ust = ws.Range("$A$1")
    ws.Activate
    ActiveWindow.View = xlPageBreakPreview
    ss = ws.UsedRange.Rows.Count
    i = 0
    If ws.Name = "Ö" Then
        ws.PageSetup.PrintArea = ""
        If ws.Range("C5") <> "" Then ws.PageSetup.PrintArea = "A1:D30"
    End If
    If ws.Name = "Sİ" Then
        ws.PageSetup.PrintArea = ""
        If ws.Range("A12") <> "" Then ws.PageSetup.PrintArea = "A1:D30"
    End If
    If ws.Name = "EA" Then
        ws.PageSetup.PrintArea = ""
        sayfa = ws.PageSetup.Pages.Count
        myrange = "B8, B54, B100, B146, B192, B238, B284, B330, B376, B422, B468, B514"
        myrange = Split(myrange, ",")
        For j = 1 To sayfa
            If Not IsEmpty(Range(myrange(i))) Then
                If j < sayfa Then
                    Set alt = Range(ws.HPageBreaks(j).Location.Address).Offset(-1, 4)
                Else
                    Set alt = Range("A" & ss).Offset(0, 4)
                    rng = (ust.Address & ":" & alt.Address)
                    unirng = unirng & "," & rng
                    Exit For
                End If
                rng = (ust.Address & ":" & alt.Address)
                Set ust = alt.Offset(1, -4)
                unirng = unirng & "," & rng
            Else
                Set alt = Range(ws.HPageBreaks(j).Location.Address).Offset(-1, 4)
                Set ust = alt.Offset(1, -4)
            End If
            i = i + 1
        Next j
        unirng = Mid(unirng, 2, Len(unirng))
        ws.PageSetup.PrintArea = unirng
        unirng = ""
    End If
    If ws.Name = "K" Then
        ws.PageSetup.PrintArea = ""
        sayfa = ws.PageSetup.Pages.Count
        myrange = "B8, B48, B88, B128, B168, B208, B248, B288, B328, B368, B408, B448"
        myrange = Split(myrange, ",")
        For j = 1 To sayfa
            If Not IsEmpty(Range(myrange(i))) Then
                If j < sayfa Then
                    Set alt = Range(ws.HPageBreaks(j).Location.Address).Offset(-1, 4)
                Else
                    Set alt = Range("A" & ss).Offset(0, 4)
                    rng = (ust.Address & ":" & alt.Address)
                    unirng = unirng & "," & rng
                    Exit For
                End If
                rng = (ust.Address & ":" & alt.Address)
                Set ust = alt.Offset(1, -4)
                unirng = unirng & "," & rng
            Else
                Set alt = Range(ws.HPageBreaks(j).Location.Address).Offset(-1, 4)
                Set ust = alt.Offset(1, -4)
            End If
            i = i + 1
        Next j
        unirng = Mid(unirng, 2, Len(unirng))
        ws.PageSetup.PrintArea = unirng
        unirng = ""
    End If
    If ws.Name = "DK" Then
        ws.PageSetup.PrintArea = ""
        sayfa = ws.PageSetup.Pages.Count
        myrange = "B8, B56, B104, B152, B200, B248, B296, B344, B392, B440, B488, B536"
        myrange = Split(myrange, ",")
        For j = 1 To sayfa
            If Not IsEmpty(Range(myrange(i))) Then
                If j < sayfa Then
                    Set alt = Range(ws.HPageBreaks(j).Location.Address).Offset(-1, 4)
                Else
                    Set alt = Range("A" & ss).Offset(0, 4)
                    rng = (ust.Address & ":" & alt.Address)
                    unirng = unirng & "," & rng
                    Exit For
                End If
                rng = (ust.Address & ":" & alt.Address)
                Set ust = alt.Offset(1, -4)
                unirng = unirng & "," & rng
            Else
                Set alt = Range(ws.HPageBreaks(j).Location.Address).Offset(-1, 4)
                Set ust = alt.Offset(1, -4)
            End If
            i = i + 1
        Next j
        unirng = Mid(unirng, 2, Len(unirng))
        ws.PageSetup.PrintArea = unirng
        unirng = ""
    End If
    ActiveWindow.View = xlNormalView
Next ws

Sheets(Array("Ö", "Sİ", "EA", "K", "DK")).Select
'Sheets(Array("Ö", "Sİ", "EA", "K", "DK")).PrintOut , preview:=True
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        ThisWorkbook.Path & "\Kontrol.pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
Sheets(1).Select
End Sub

 

[GLMNYX]

çok teşekkür ederim, çalışma mantığı nasıl olacak nasıl bir yol izlemeliyim? yeni bir makro olarak kayıtmı yapmam gerekiyor?
Set alt = Range(ws.HPageBreaks(j).Location.Address).Offset(-1, 4) hata verdi

 

[necati]

çok teşekkür ederim, çalışma mantığı nasıl olacak nasıl bir yol izlemeliyim? yeni bir makro olarak kayıtmı yapmam gerekiyor?

Sn. GLMNYX örnek dosya paylaşmadığınıza göre uyarlamayı kendiniz yapmalısınız.

 

[GLMNYX]

Sn. GLMNYX örnek dosya paylaşmadığınıza göre uyarlamayı kendiniz yapmalısınız.

örnek dosya derken tamam pardon kusura bakmayın ben kod anladım ,excel dosyasını istiyorsunuz.