Kaç Sayfa Makrosu

[beta12]

Bendenizin bir excel dosyası var.
Burada aktif sekmelerin yazdırılması için bir makro ürettim
Fakat bir eksiğim var.
Makromdaki 'Cevap Kağıdı' sekmesinin en son yazılmasını ve 'kaç adet
basılsın'ı bildiren bir msgbox olmasını istiyorum.
Kod aşağıda:

Sub tümyazdır()
'
' tümyazdır Makro

ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
Sheets("SINAV TUTANAĞI").Select
ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
Sheets("SORU TUTANAĞI").Select
ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
Sheets("CEVAP TUTANAĞI").Select
ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
Sheets("PARA TUTANAĞIDIR").Select
ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
Sheets("GÖREVLİ İMZA ÇİZELGESİ").Select
ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
Sheets("SARF TUTANAĞI").Select
ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
Sheets("NOT FİŞİ").Select
ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
Sheets("CEVAP KAĞIDI").Select
ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
Sheets("EVRAK TESLİM ").Select
ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
Sheets("GİRİLMEDİ").Select
ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
End Sub

 

[Seyit Tiken]

Sub Düğme1_Tıklat()
On Error Resume Next
s = InputBox("Kopya Sayısı Girin")
For t = 1 To Sheets.Count
Sheets(t).PrintOut copies:=s
Next
End Sub

Kendinize uyarlayınız.

 

[beta12]

Kodu bir türlü ayarlayamadım. Dosyayı yüklüyorum. Kodu benim için eklerseniz sevinirim.
Bu arada, BİLGİ GİRİŞİ'nde Dersi Kısmında: Pratik Eğitim ekleyebileceğim bir açılır kutu konulabilir mi acaba? Zira Pratik Eğitim derslerinin sınav süreleri tam 4 saat sürer. Diğer bütün dersler 1 saatte bitiyor. O dersleri manuel girerim. Ama Açılır kutu eşliğinde girebileceğim 'Pratik Eğitim' Dersi'nin 'Sınav Tutanağı' sekmesinde,
SINAVIN SONA ERDİĞİ SAAT: (Sınavın başlangıcından 4 saat sonra)
İNCELEMENİN YAPILDIĞI SAATSınavın başlangıcından 4 saat 15 dakika sonra)
ile 'Girilmedi' sekmesinde de:
"Komisyon üyeleri ve sınav gözetmeni / gözetmenleri öğrencileri saat : (sınavın başlangıcından 4 saat sonra)
formüllerinin ayarlanması gerekir.
Yani Pratik Eğitim ile öteki derslerin sınav süreleri aynı değil.
Önemli olan programın bu sorunu ortadan kaldırması.
Bu da sanırım açılır kutu sayesinde çözülebilir.

 

[beta12]

Yardımcı olacak bir arkadaş yok mu;- rica etsem bir uzman arkadaşımız bu sorunumu giderse!

 

[Orion1]

Ne istediğinizi anlamdım.
sayaflarmı yazılacak.Hangi aralık yazılacak?Bütün hepsimi yazılacack.Soru açık değil.

 

[uzmanamele]

merhaba

bu mudur?

Sub tümyazdır()
'
' tümyazdır Makro

    ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
    Sheets("SINAV TUTANAĞI").Select
    ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
    Sheets("SORU TUTANAĞI").Select
    ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
    Sheets("CEVAP TUTANAĞI").Select
    ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
    Sheets("PARA TUTANAĞIDIR").Select
    ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
    Sheets("GÖREVLİ İMZA ÇİZELGESİ").Select
    ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
    Sheets("SARF TUTANAĞI").Select
    ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
    Sheets("NOT FİŞİ").Select
    ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"

    Sheets("EVRAK TESLİM ").Select
    ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
    Sheets("GİRİLMEDİ").Select
    ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
    
        Sheets("CEVAP KAĞIDI").Select
        ks = InputBox("Kopya Sayısı Girin")
        ExecuteExcel4Macro "PRINT(ks,,,1,,,,,,,,2,,,TRUE,,FALSE)"
End Sub

 

[beta12]

Şöyle bir sorun var. Cevap Kağıdının kopya sayını yazıyorum. Ama söz konusu sayı oranında cevap kağıdı yazıcıdan çıkmıyor. Yani cevap kağıdı 'print' edilemiyor.

 

[mancubus]

Merhaba.

Benim kullandığım şöyle bir macro var. Birden çok sayfayı aynı anda yazdırıyor.
Benim örnekte sayfa isimleri 1'den 10'a kadar rakamlardan oluşuyor. Dosyadaki 9 isimli sayfa hariç tüm sayfaları olduğu şekilde 1 kopya, 9 isimli sayfayı ise 1. sayfasını (9 isimli sheet'in A4 boyutunda yazdırılacak ilk sayfasını kastediyorum) 5 kopya olarak basıyor.

Belki uyarlayabilirsiniz. 2003 ve 2007 için test edilmiştir.

Birden çok yazıcı kullandığımız için bende kırmızı olan bölüm de var. Sizin tek yazıcınız var ise veya zaten seçili ve değişmeyecek ise o bölümü silebilirsiniz.

Birden çok nüsha yazdırıldığında sayfa basım sırasını düzenleyen yeşil bölümü kendinize uyarlayabilirsiniz. veya mevcut tanımlı değerlerinizin kalması için silebilirsiniz.

Sayfanızın tamamı yazdırılacak ise mavi bölümü de silmelisiniz.

Tabii bu makro sonuncunun kaç kopya print alınacağını sormamaktadır. onu yukarıdaki kodlardan ayrıca ekleyebilir veya standart bir rakam ise benim örnekteki 5'in yerine girebilirsiniz.

Sub Print()

    Sheets(Array("1", "2", "3", "4", "5", "6", "7", "8", "10")).Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1[COLOR="Red"], ActivePrinter:= _
        "\\HMKPRTV12\PRLHMK28 on Ne03:",[/COLOR] [COLOR="SeaGreen"]Collate:=True[/COLOR]
    Worksheets("9").PrintOut [COLOR="Blue"]from:=1, To:=1,[/COLOR] Copies:=5

End Sub

 

[mancubus]

Merhaba.
Konu ilgimi çektiği için biraz araştırma yaptım. Net kaynaklı bir çözüm buldum. Bende çalıştı.

Sub Print()

Dim Sh As Worksheet
Dim copies As String
Dim sPrompt As String
Dim sTitle As String
Dim sDefault As String

sPrompt = "Kaç Nüsha Yazdırmak İstiyorsunuz"
sTitle = "Sınav Belgesi Yazdırma"
sDefault = "1"
copies = InputBox(sPrompt, sTitle, sDefault)

    Sheets(Array("SINAV TUTANAĞI", "SORU TUTANAĞI", "CEVAP TUTANAĞI", _
"PARA TUTANAĞIDIR", "GÖREVLİ İMZA ÇİZELGESİ", "SARF TUTANAĞI", _
"NOT FİŞİ", "EVRAK TESLİM ", "GİRİLMEDİ")).Select
    ActiveWindow.SelectedSheets.PrintOut copies:=1
    Worksheets("CEVAP KAĞIDI").PrintOut from:=1, To:=1, copies:=copies

On Error GoTo Hata

Hata:
MsgBox "Yazdırılacak sayfa yok!"

End Sub

 

[halit3]

ekli dosyada yazdırma seçenek düğmesi var bir bakarmısınız.

 

[beta12]

Yardımcı olan herkese teşekkürlerimi sunuyorum. Bu arada Halit3 düşündüğümün de ötesinde bir katkı sağlamış. Harika.
Exceli sevmemek mümkün mü böyle çalışmaları görünce,