Şartlı Yazdırma Hk

O

ormann

Katılım
9 Ekim 2009
Mesajlar
1,626
Excel Vers. ve Dili
türkçe
2003
Merhabalar;
Veri girişi sayfasında O18 hücresinde veri yoksa sadece EBAT-1 sayfasının tamamını yazacak. Eğer O18 hücresinde veri varsa hem EBAT-1 sayfasını hemde EBAT-2 sayfasını yazacak. Ama EBAT-1 sayfasında A71:AC79 hücre içerisindeki veriyi yazmayıp sadece EBAT-2 sayfasında yazacak.

İndir EBAT LİSTESİ PROGRAMI

Dosyayı indir EBAT LİSTESİ PROGRAMI
dosya.co
 
O

ormann

Katılım
9 Ekim 2009
Mesajlar
1,626
Excel Vers. ve Dili
türkçe
2003
İyi akşamlar,
Arkadaşlar rica etsem 1.nolu mesajımda açmış olduğum konuya yardımcı olur musunuz .Saygilar
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,367
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++: 
Option Explicit

Sub Kosullu_Yazdir()
    Dim Adet As Variant, S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, Veri As Range
    
    Adet = Application.InputBox("Yazdırılacak sayfa adedini giriniz.", "Sayfa Adedi Girişi", 2)
    
    If Not IsNumeric(Adet) Then
        MsgBox "Lütfen sayısal değer giriniz!", vbCritical
        Exit Sub
    End If
    
    If Adet = False Then
        MsgBox "Yazdırma işlemi iptal edilmiştir!", vbCritical
        Exit Sub
    End If
    
    If Adet <= 0 Then
        MsgBox "Yazdırma işlemi için sıfırdan büyük pozitif değer giriniz!", vbCritical
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("VERİ GİRİŞİ")
    Set S2 = Sheets("EBAT -1")
    Set S3 = Sheets("EBAT -2")
    
    If S1.Range("O18") = 0 Then
        With S2
            .Cells.EntireRow.Hidden = False
            For Each Veri In .Range("AA19:AA68")
                If Veri.Value = 0 Then Veri.EntireRow.Hidden = True
            Next
            .PrintOut Copies:=Adet
            .Cells.EntireRow.Hidden = False
        End With
    Else
        With S2
            For Each Veri In .Range("AA19:AA68")
                If Veri.Value = 0 Then Veri.EntireRow.Hidden = True
            Next
            .Range("A71:A79").EntireRow.Hidden = True
            .PrintOut Copies:=Adet
            .Cells.EntireRow.Hidden = False
        End With
        With S3
            .Cells.EntireRow.Hidden = False
            For Each Veri In .Range("AA19:AA68")
                If Veri.Value = 0 Then Veri.EntireRow.Hidden = True
            Next
            .PrintOut Copies:=Adet
            .Cells.EntireRow.Hidden = False
        End With
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Yazdırma işlemi tamamlanmıştır.", vbInformation
End Sub
 
O

ormann

Katılım
9 Ekim 2009
Mesajlar
1,626
Excel Vers. ve Dili
türkçe
2003
Korhan bey yardımınız için çok teşekkür ederim.
Makro iki koşulda da EBAT-1 sayfasını yazdırıyor. Veri girişi sayfasında O18 hücresinde veri yoksa sadece EBAT-1 sayfasının tamamını yazacak. Eğer O18 hücresinde veri varsa hem EBAT-1 sayfasını hemde EBAT-2 sayfasını yazacak. Ama EBAT-1 sayfasında A71:AC79 hücre içerisindeki veriyi yazmayıp sadece EBAT-2 sayfasınıda yazacak.
NoT: Yazdırma butonuna bastığımızda Yazdırılacak sayfa adedi giriniz diye bir kutucuk açılsa .Yazdırılacak adedi girdiğimizde tamam deyince yazsa. İptal deyince vazgeçilse. Ayrıca kutucuk içerisine 2 adet hazır yazılacağı hazır gelse biz onu değiştirebilsek. Makroyu bu şekilde revize edebilir misiniz
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,069
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Şu kısmı Ebat 2 olarak değiştirmeniz gerekir:

Sheets("EBAT -1").PrintOut
End If
 
O

ormann

Katılım
9 Ekim 2009
Mesajlar
1,626
Excel Vers. ve Dili
türkçe
2003
Yusuf bey teşekkür ederim. EBAT1- ve EBAT-2 sayfasında AA19:AA68 hücre aralığında değeri "0" olan hücrelerin bulundukarı satırlar gizlenip ; yazdırma işlemi bittikten sonra gizlenen satırlar gösterilebilir mi? Ayrıca ,Yazdırma butonuna bastığımızda Yazdırılacak sayfa adedi giriniz diye bir kutucuk açılsa .Yazdırılacak adedi girdiğimizde tamam deyince yazsa. İptal deyince vazgeçilse. Ayrıca kutucuk içerisine 2 adet hazır yazılacağı hazır gelse biz onu değiştirebilsek. Makroyu bu şekilde revize edebilir misiniz .Buda yapılabilirse tamam olacak
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,367
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
#3 nolu mesajımda ki kodu revize ettim. Tekrar deneyiniz.

Önemli Not: Taleplerinizin tümünü ilk mesajınızda belirtirseniz cevap verenler sürekli olarak konuyla ilgilenmek durumunda kalmazlar.
 
O

ormann

Katılım
9 Ekim 2009
Mesajlar
1,626
Excel Vers. ve Dili
türkçe
2003
Sayın Korhan hocam çok teşekkür ederim. Kod süper çalışıyor. Veri girişi sayfasında O18 hücresinde veri yoksa satırını O18:V18 şeklinde değiştirebilirmiyiz .Ben değiştirdim fakat
Kod: 
If S1.Range("O18:v18") = 0 Then
 
O

ormann

Katılım
9 Ekim 2009
Mesajlar
1,626
Excel Vers. ve Dili
türkçe
2003
Sayın Korhan hocam çok teşekkür ederim. Kod süper çalışıyor. Veri girişi sayfasında O18 hücresinde veri yoksa satırını O18:V18 şeklinde değiştirebilirmiyiz .Ben değiştirdim fakat kod hata verdi.
Kod: 
If S1.Range("O18:v18") = 0 Then
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,367
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Bu aralıktaki değerler hep pozitif oluyorsa aşağıdaki gibi olabilir.

C++: 
If WorksheetFunction.Sum(S1.Range("O18:v18")) = 0 Then
 
O

ormann

Katılım
9 Ekim 2009
Mesajlar
1,626
Excel Vers. ve Dili
türkçe
2003
Korhan bey çok teşekkür ederim.Kodlar tam istediğim gibi.Ellerinize sağlik
 
O

ormann

Katılım
9 Ekim 2009
Mesajlar
1,626
Excel Vers. ve Dili
türkçe
2003
Korhan bey hocam iyi akşamlar;
Aşağıda yazdırma ile ilgili yapmış olduğunuz kodu, yazdırma ile ilgili değilde ön izleme için yapa bilir misiniz.
Kod: 
Option Explicit

Sub Kosullu_Yazdir()
    Dim Adet As Variant, S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, Veri As Range
    
    Adet = Application.InputBox("Yazdırılacak sayfa adedini giriniz.", "Sayfa Adedi Girişi", 2)
    
    If Not IsNumeric(Adet) Then
        MsgBox "Lütfen sayısal değer giriniz!", vbCritical
        Exit Sub
    End If
    
    If Adet = False Then
        MsgBox "Yazdırma işlemi iptal edilmiştir!", vbCritical
        Exit Sub
    End If
    
    If Adet <= 0 Then
        MsgBox "Yazdırma işlemi için sıfırdan büyük pozitif değer giriniz!", vbCritical
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("VERİ GİRİŞİ")
    Set S2 = Sheets("EBAT -1")
    Set S3 = Sheets("EBAT -2")
    
    If S1.Range("O18") = 0 Then
        With S2
            .Cells.EntireRow.Hidden = False
            For Each Veri In .Range("AA19:AA68")
                If Veri.Value = 0 Then Veri.EntireRow.Hidden = True
            Next
            .PrintOut Copies:=Adet
            .Cells.EntireRow.Hidden = False
        End With
    Else
        With S2
            For Each Veri In .Range("AA19:AA68")
                If Veri.Value = 0 Then Veri.EntireRow.Hidden = True
            Next
            .Range("A71:A79").EntireRow.Hidden = True
            .PrintOut Copies:=Adet
            .Cells.EntireRow.Hidden = False
        End With
        With S3
            .Cells.EntireRow.Hidden = False
            For Each Veri In .Range("AA19:AA68")
                If Veri.Value = 0 Then Veri.EntireRow.Hidden = True
            Next
            .PrintOut Copies:=Adet
            .Cells.EntireRow.Hidden = False
        End With
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Yazdırma işlemi tamamlanmıştır.", vbInformation
End Sub
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,367
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Önizleme de ki durumda yazdırma işleminde mantıkla olacaksa kod içindeki aşağıdaki satırları;

.PrintOut Copies:=Adet

Bir alttaki kod ile değiştirip deneyiniz.

.PrintPreview
 
O

ormann

Katılım
9 Ekim 2009
Mesajlar
1,626
Excel Vers. ve Dili
türkçe
2003
Korhan bey hocam merhabalar;
Ekli dosyamda veri girişi sayfasındaki yazdır butonu ile şartlı olarak aşağıdaki makro ile Ebat-1 ve Ebat-2 sayfalarını yazdırabiliyoruz. Yazdır Butonuna bastığımız da 3 sayfa yazdırıyoruz. Acaba yazdır butonuna bastığımızda 1. Çıktıya
veri girişi sayfasındaki F9 Hücresindeki veriyi Ebat-1 sayfasında J12 hücresine
veri girişi sayfasındaki F10 Hücresindeki veriyi Ebat-1 sayfasında J11 hücresindeki verileri yazdırabilir miyiz .Not:2 ve 3. çıktılar da veriler yazılmayacak.

Dosya Link:

İndir EBAT SON xlsm

Dosyayı indir EBAT SON xlsm
dosya.co

Kod: 
Sub Kosullu_Yazdir()
    Beep
    Sheets("EBAT -1").Unprotect 123
    Sheets("EBAT -2").Unprotect 123
    Dim Adet As Variant, S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, Veri As Range
    If Sheets("VERİ GİRİŞİ").Range("J4") = Empty Then MsgBox "LÜTFEN İŞLETME MÜDÜRLÜĞÜNÜ SEÇİNİZ ?": Sheets("VERİ GİRİŞİ").Range("J4").Select: Exit Sub
    If Sheets("VERİ GİRİŞİ").Range("J5") = Empty Then MsgBox "LÜTFEN İŞLETME ŞEFLİĞİNİ SEÇİNİZ ?": Sheets("VERİ GİRİŞİ").Range("J5").Select: Exit Sub
    If Sheets("VERİ GİRİŞİ").Range("J6") = Empty Then MsgBox "LÜTFEN İSTİF YERİNİ GİRİNİZ?": Sheets("VERİ GİRİŞİ").Range("J6").Select: Exit Sub
    If Sheets("VERİ GİRİŞİ").Range("J7") = Empty Then MsgBox "LÜTFEN İSTİF TARİHİNİ GİRİNİZ?": Sheets("VERİ GİRİŞİ").Range("J7").Select: Exit Sub
    If Sheets("VERİ GİRİŞİ").Range("J8") = Empty Then MsgBox "LÜTFEN İSTİF NUMARASININ GİRİNİZ ?": Sheets("VERİ GİRİŞİ").Range("J8").Select: Exit Sub
    If Sheets("VERİ GİRİŞİ").Range("J10") = Empty Then MsgBox "LÜTFEN EMVALİN CİNS VE NEVİNİ GİRİNİZ ?": Sheets("VERİ GİRİŞİ").Range("J10").Select: Exit Sub
    
    
    Adet = Application.InputBox("Yazdırılacak sayfa adedini giriniz.", "Sayfa Adedi Girişi", 3)
    
    If Not IsNumeric(Adet) Then
        MsgBox "Lütfen sayısal değer giriniz!", vbCritical
        Exit Sub
    End If
    
    If Adet = False Then
        MsgBox "Yazdırma işlemi iptal edilmiştir!", vbCritical
        Exit Sub
    End If
    
    If Adet <= 0 Then
        MsgBox "Yazdırma işlemi için sıfırdan büyük pozitif değer giriniz!", vbCritical
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("VERİ GİRİŞİ")
    Set S2 = Sheets("EBAT -1")
    Set S3 = Sheets("EBAT -2")
    
    If WorksheetFunction.Sum(S1.Range("O18:v18")) = 0 Then
        With S2
            .Cells.EntireRow.Hidden = False
            For Each Veri In .Range("AA19:AA68")
                If Veri.Value = 0 Then Veri.EntireRow.Hidden = True
            Next
            .PrintOut Copies:=Adet
            .Cells.EntireRow.Hidden = False
        End With
    Else
        With S2
            For Each Veri In .Range("AA19:AA68")
                If Veri.Value = 0 Then Veri.EntireRow.Hidden = True
            Next
            .Range("A71:A79").EntireRow.Hidden = True
            .PrintOut Copies:=Adet
            .Cells.EntireRow.Hidden = False
        End With
        With S3
            .Cells.EntireRow.Hidden = False
            For Each Veri In .Range("AA19:AA68")
                If Veri.Value = 0 Then Veri.EntireRow.Hidden = True
            Next
            .PrintOut Copies:=Adet
            .Cells.EntireRow.Hidden = False
        End With
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Yazdırma işlemi tamamlanmıştır.", vbInformation
 Sheets("EBAT -1").Protect 123
 Sheets("EBAT -2").Protect 123
End Sub
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,367
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
1. Çıktı'dan kastınız nedir?
 
O

ormann

Katılım
9 Ekim 2009
Mesajlar
1,626
Excel Vers. ve Dili
türkçe
2003
Korhan bey merhabalar,
Yazdır butonuna bastığımızda bize kutucuk açılıyor.Kutucuğun içerisinde sayfa adedi 3 yazıyor.Yazdır dediğimde aynı sayfadan 3 adet yazdırıyor.Benim istediğim , 1. Adette çıktıda belirttiğim hücrelerdeki veriler yazılacak.Diğer çıktılarda belirttiğim hücrelerdeki veriler gözükmeyecek
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,367
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Adet kutusuna 1 yazma durumu var mı? Varsa bu durumda işlem nasıl olacak?

Ek olarak hücre adreslerinde bir sıkıntı yok değil mi? İlgili hücrelerde aşağıdakiler yazıyor.

VERİ GİRİŞİ F9 = PARTİ NO
VERİ GİRİŞİ F10 = CİNS NEVİ-SINIF

Ayrıca EBAT-1 sayfasında J11 ve J12 hücreleri birleştirilmiş hücre görünüyor. Bu sebeple adresler hatalı olmuş oluyor.

Bu hücreler aslında F11 ve F12 hücreleri oluyor.
 
O

ormann

Katılım
9 Ekim 2009
Mesajlar
1,626
Excel Vers. ve Dili
türkçe
2003
Adet kutusuna 1 yazma durumu var . 1 yazdığımızda aşağıda ki verileri yazmayacak .Adet kutusuna 1 den fazla yazdığım zaman 1.çıktıya yazacak. Diğerlerinde gözükmeyecek
Veri Girişi J11 hücresindeki veriyi Ebat-1 sayfasında F10 hücresine yazacak
Veri Girişi J12 hücresindeki veriyi Ebat-1 sayfasında F9 hücresine yazacak.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,367
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++: 
Sub Kosullu_Yazdir()
    Beep
    Sheets("EBAT -1").Unprotect 123
    Sheets("EBAT -2").Unprotect 123
    Dim Adet As Variant, S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, Veri As Range
    If Sheets("VERİ GİRİŞİ").Range("J4") = Empty Then MsgBox "LÜTFEN İŞLETME MÜDÜRLÜĞÜNÜ SEÇİNİZ ?": Sheets("VERİ GİRİŞİ").Range("J4").Select: Exit Sub
    If Sheets("VERİ GİRİŞİ").Range("J5") = Empty Then MsgBox "LÜTFEN İŞLETME ŞEFLİĞİNİ SEÇİNİZ ?": Sheets("VERİ GİRİŞİ").Range("J5").Select: Exit Sub
    If Sheets("VERİ GİRİŞİ").Range("J6") = Empty Then MsgBox "LÜTFEN İSTİF YERİNİ GİRİNİZ?": Sheets("VERİ GİRİŞİ").Range("J6").Select: Exit Sub
    If Sheets("VERİ GİRİŞİ").Range("J7") = Empty Then MsgBox "LÜTFEN İSTİF TARİHİNİ GİRİNİZ?": Sheets("VERİ GİRİŞİ").Range("J7").Select: Exit Sub
    If Sheets("VERİ GİRİŞİ").Range("J8") = Empty Then MsgBox "LÜTFEN İSTİF NUMARASININ GİRİNİZ ?": Sheets("VERİ GİRİŞİ").Range("J8").Select: Exit Sub
    If Sheets("VERİ GİRİŞİ").Range("J10") = Empty Then MsgBox "LÜTFEN EMVALİN CİNS VE NEVİNİ GİRİNİZ ?": Sheets("VERİ GİRİŞİ").Range("J10").Select: Exit Sub
    
    
    Adet = Application.InputBox("Yazdırılacak sayfa adedini giriniz.", "Sayfa Adedi Girişi", 3)
    
    If Not IsNumeric(Adet) Then
        MsgBox "Lütfen sayısal değer giriniz!", vbCritical
        Exit Sub
    End If
    
    If Adet = False Then
        MsgBox "Yazdırma işlemi iptal edilmiştir!", vbCritical
        Exit Sub
    End If
    
    If Adet <= 0 Then
        MsgBox "Yazdırma işlemi için sıfırdan büyük pozitif değer giriniz!", vbCritical
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("VERİ GİRİŞİ")
    Set S2 = Sheets("EBAT -1")
    Set S3 = Sheets("EBAT -2")
    
    If WorksheetFunction.Sum(S1.Range("O18:v18")) = 0 Then
        With S2
            .Cells.EntireRow.Hidden = False
            For Each Veri In .Range("AA19:AA68")
                If Veri.Value = 0 Then Veri.EntireRow.Hidden = True
            Next
            If Adet > 1 Then
                S2.Range("F10") = S1.Range("J11")
                S2.Range("F9") = S1.Range("J12")
                .PrintOut Copies:=1
                S2.Range("F12") = ""
                S2.Range("F11") = ""
                .PrintOut Copies:=Adet - 1
            Else
                S2.Range("F12") = ""
                S2.Range("F11") = ""
                .PrintOut Copies:=Adet
            End If
            .Cells.EntireRow.Hidden = False
        End With
    Else
        With S2
            For Each Veri In .Range("AA19:AA68")
                If Veri.Value = 0 Then Veri.EntireRow.Hidden = True
            Next
            .Range("A71:A79").EntireRow.Hidden = True
            .PrintOut Copies:=Adet
            .Cells.EntireRow.Hidden = False
        End With
        With S3
            .Cells.EntireRow.Hidden = False
            For Each Veri In .Range("AA19:AA68")
                If Veri.Value = 0 Then Veri.EntireRow.Hidden = True
            Next
            .PrintOut Copies:=Adet
            .Cells.EntireRow.Hidden = False
        End With
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    
    Sheets("EBAT -1").Protect 123
    Sheets("EBAT -2").Protect 123
    
    Application.ScreenUpdating = True
    
    MsgBox "Yazdırma işlemi tamamlanmıştır.", vbInformation
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst