• DİKKAT

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

Yazdır makrosu

E

Erdal

Altın Üye
Katılım
23 Ekim 2006
Mesajlar
1,057
Excel Vers. ve Dili
Ev: 2021 - Türkçe 32 Bit
İşyeri: 2016 - Türkçe 64 Bit
Merhabalar
Amacım işaretlemiş olduğum sayfaları yazdırma alanı belirleyerek yazdırmak. Bunun için de makro kaydet yöntemini kullandım ama bazı şeyleri beceremedim ayrıca da hata mesajı aldım. Şöyle ki;
- Makro 1 ile toplam 14 sayfa yazdırmak istiyorum. Yazdır butonuna tıkladığımda bu 14 sayfa yazdırılacak. Seçtiğim alan sığmıyorsa yazdırma alanı belirleyerek sığdırıp yazdırılacak. (6,7 ve 12. Sayfalar yatay diğerleri dikey yazdırılacak) Ben bunları makro kaydet ile yaptım ve bir commandbutona atadım. Butonu tıklayınca 1. Sayfanın baskı ön izlemesi ekrana geliyor ve orada takılıyor. Ancak baskı ön izlemeyi kapatınca 1. Sayfayı yazdırıyor ve 2. Sayfanın baskı ön izlemesi ekrana geliyor ve bu şekilde devam edip gidiyor.
- Makro 2 ile de toplam 13 sayfa yazdırmak istiyorum. Bunda da mantık aynı şekilde. . (6,7 ve 12. Sayfalar yatay diğerleri dikey yazdırılacak) Fakat butona tıkladığımda örnekteki hatayı alıyorum.
- Ayrıca butona bastığımızda önce kaç nüsha yazdırmak istediğimi sorsun. (Hiç bir şey yazmazsam mümkünse 1 kabul etsin) Sonrasında ise yazdırsın. Kodlara bu eklenebilir mi?
 

Ekli dosyalar

kod:

Kod: 
Sub yazdır1()


ReDim yön(14)
ReDim yaz(14)

yön(1) = xlPortrait 'dikey
yön(2) = xlPortrait 'dikey
yön(3) = xlPortrait 'dikey
yön(4) = xlPortrait 'dikey
yön(5) = xlPortrait 'dikey
yön(6) = xlLandscape 'yatay
yön(7) = xlLandscape 'yatay
yön(8) = xlPortrait 'dikey
yön(9) = xlPortrait 'dikey
yön(10) = xlPortrait 'dikey
yön(11) = xlPortrait 'dikey
yön(12) = xlLandscape 'yatay
yön(13) = xlPortrait 'dikey
yön(14) = xlPortrait 'dikey


yaz(1) = "$A$3:$I$51"
yaz(2) = "$M$3:$V$72"
yaz(3) = "$M$74:$V$143"
yaz(4) = "$Z$3:$AK$64"
yaz(5) = "$AO$2:$BJ$55"
yaz(6) = "$BN$3:$CU$50"
yaz(7) = "$CY$2:$DT$49"
yaz(8) = "$DX$4:$EK$39"
yaz(9) = "$DX$59:$EK$93"
yaz(10) = "$DX$100:$EK$130"
yaz(11) = "$DX$138:$EK$166"
yaz(12) = "$BO$4:$FD$49"
yaz(13) = "$FH$3:$FK$57"
yaz(14) = "$FV$3:$FY$57"


adet = Application.InputBox("Yazdırmak İstiyormusunuz.", "Yazdırılacak kadar sayı giriniz.", "1", 400, 30, , Type:=1)
    
If adet = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If


[COLOR="red"]ActiveSheet.PageSetup.Zoom = False[/COLOR]
For i = 1 To 14
Worksheets(ActiveSheet.Name).PageSetup.Orientation = yön(i)
Worksheets(ActiveSheet.Name).PageSetup.PrintArea = yaz(i)
ActiveWindow.SelectedSheets.PrintPreview
Worksheets(ActiveSheet.Name).PrintOut Copies:=adet, Collate:=True
Next i
[COLOR="Red"]Worksheets(ActiveSheet.Name).PageSetup.PrintArea = ""[/COLOR]

MsgBox ("işlem tamam."), vbInformation, "UYARI"

End Sub
 
halit3' Alıntı:
kod:

Kod: 
Sub yazdır1()


ReDim yön(14)
ReDim yaz(14)

yön(1) = xlPortrait 'dikey
yön(2) = xlPortrait 'dikey
yön(3) = xlPortrait 'dikey
yön(4) = xlPortrait 'dikey
yön(5) = xlPortrait 'dikey
yön(6) = xlLandscape 'yatay
yön(7) = xlLandscape 'yatay
yön(8) = xlPortrait 'dikey
yön(9) = xlPortrait 'dikey
yön(10) = xlPortrait 'dikey
yön(11) = xlPortrait 'dikey
yön(12) = xlLandscape 'yatay
yön(13) = xlPortrait 'dikey
yön(14) = xlPortrait 'dikey


yaz(1) = "$A$3:$I$51"
yaz(2) = "$M$3:$V$72"
yaz(3) = "$M$74:$V$143"
yaz(4) = "$Z$3:$AK$64"
yaz(5) = "$AO$2:$BJ$55"
yaz(6) = "$BN$3:$CU$50"
yaz(7) = "$CY$2:$DT$49"
yaz(8) = "$DX$4:$EK$39"
yaz(9) = "$DX$59:$EK$93"
yaz(10) = "$DX$100:$EK$130"
yaz(11) = "$DX$138:$EK$166"
yaz(12) = "$BO$4:$FD$49"
yaz(13) = "$FH$3:$FK$57"
yaz(14) = "$FV$3:$FY$57"


adet = Application.InputBox("Yazdırmak İstiyormusunuz.", "Yazdırılacak kadar sayı giriniz.", "1", 400, 30, , Type:=1)
    
If adet = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If

For i = 1 To 14
ActiveSheet.PageSetup.Orientation = yön(i)
Worksheets(ActiveSheet.Name).PageSetup.PrintArea = yaz(i)
Worksheets(ActiveSheet.Name).PrintOut Copies:=adet, Collate:=True
Next i

MsgBox ("işlem tamam."), vbInformation, "UYARI"

End Sub
Genişletmek için tıkla ...
İlginiz için teşekkür ederim Halit Bey
Aşağıdaki husularda yardımcı olabilir misiniz acaba?
- 12. sayfa BO4-FD49 arası değilde EO4-FD49 arası olack. Ben EO4 yazdığım halde yazıcıdan gene BO4 diye çıkıyor.
- Yazdırma işlemine başlamadan evvel sayfadaki tüm dolgu renklerini "dolgu yok seçeneği ile kaldırmak için kodları nasıl revize ederiz.
- İşlem tamam mesaj kutusunu kaldırabilir miyiz?
- 2 sayfasındaki butonda 13 sayfa var. Vermiş olduğunuz kodlardaki yön(14) = xlPortrait 'dikey, yaz(14) = "$FV$3:$FY$57" satırlarını silmem ve For i = 1 To 14 satırını 13 yapmam yeterlimidir? Saygı ve selam ile ...
 
1-3 ve 4. maddeleri hallettim. Sadece yazdırmaya başlamadan evvel sayfadaki dolgu renklerinin dolgu yok şeklinde ayarlanması ile ilgili 2. madde kaldı. Bu konuda yardımcı olabilir misiniz?
 
dolgu olayı için sayın halit3'ün kodlarındaki :

Kod: 
For i = 1 To 14
ActiveSheet.PageSetup.Orientation = yön(i)
Worksheets(ActiveSheet.Name).PageSetup.PrintArea = yaz(i)
Worksheets(ActiveSheet.Name).PrintOut Copies:=adet, Collate:=True
Next i
bölümünü aşağıdaki gibi değiştirerek dener misiniz?
Kod: 
For i = 1 To 14
Range(yaz(i)).Select
With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
End With
ActiveSheet.PageSetup.Orientation = yön(i)
Worksheets(ActiveSheet.Name).PageSetup.PrintArea = yaz(i)
Worksheets(ActiveSheet.Name).PrintOut Copies:=adet, Collate:=True
Range(yaz(i)).Select
With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
End With
Next i
 
İlginiz için teşekkür ederim Yusuf Bey. Tam istediğim gibi.
 
YUSUF44' Alıntı:
dolgu olayı için sayın halit3'ün kodlarındaki :

Kod: 
For i = 1 To 14
ActiveSheet.PageSetup.Orientation = yön(i)
Worksheets(ActiveSheet.Name).PageSetup.PrintArea = yaz(i)
Worksheets(ActiveSheet.Name).PrintOut Copies:=adet, Collate:=True
Next i
bölümünü aşağıdaki gibi değiştirerek dener misiniz?
Kod: 
For i = 1 To 14
Range(yaz(i)).Select
With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
End With
ActiveSheet.PageSetup.Orientation = yön(i)
Worksheets(ActiveSheet.Name).PageSetup.PrintArea = yaz(i)
Worksheets(ActiveSheet.Name).PrintOut Copies:=adet, Collate:=True
Range(yaz(i)).Select
With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
End With
Next i
Genişletmek için tıkla ...
Yusuf Bey tahmin edemediğim şöyle bir problem oldu; acaba yazdırma işlemine başlamadan sayfa yapısından kenar boşluklarını (Evvelki ne olursa olsun) sol= 1,8 alt ve üst = 1 olarak ayarlamak için kodlara nasıl bir ilave yapmak gerekir.
 
İlk End With satırından sonra aşağıdaki kodları ilave edip dener misiniz?

Kod: 
With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.708661417322835)
        .TopMargin = Application.InchesToPoints(0.393700787401575)
        .BottomMargin = Application.InchesToPoints(0.393700787401575)
End With
 
YUSUF44' Alıntı:
İlk End With satırından sonra aşağıdaki kodları ilave edip dener misiniz?

Kod: 
With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.708661417322835)
        .TopMargin = Application.InchesToPoints(0.393700787401575)
        .BottomMargin = Application.InchesToPoints(0.393700787401575)
End With
Genişletmek için tıkla ...

Merhabalar Yusuf Bey
İşlerin yoğunluğundan geri dönüş yapamadım. Kusura bakmayın.
Verilen kodları orjinal dosyaya atınca yazdırma alanı belirleme işi hata veriyor. (Örnek dosyada bir sıkıntı yok). Kenar boşluklarını ayarlama ve dolgu rengini ayarlama işlerinde bir sıkıntı yok sadece istediğim alanları yazmıyor. Orjinal dosyayı yolluyorum. acaba yardımcı olabilir misiniz. saygı ve selam ile...
 

Ekli dosyalar

Bunun nedeni kenar boşluklarınızın ve kağıt ebadınızın seçili alanlara uymaması diye düşünüyorum. Örneğin 2. sayfa olarak belirlenen alan 4 sayfaya sığıyor. Dolayısıyla yazdırma işi de istediğiniz gibi olmuyor. Sorunu düzeltmek için Satır yükseklikleriyle ve sütun genişliklerini değiştirmeniz gerekir.

Şimdi baktım, örnek dosyanızda sayfayı 1 sayfaya sığdır seçeneği seçili, asıl dosyanızda ise bu seçili değil. Aynı şeyi asıl dosyanızda da yaparsanız sorun düzelir galiba.
 
YUSUF44' Alıntı:
Bunun nedeni kenar boşluklarınızın ve kağıt ebadınızın seçili alanlara uymaması diye düşünüyorum. Örneğin 2. sayfa olarak belirlenen alan 4 sayfaya sığıyor. Dolayısıyla yazdırma işi de istediğiniz gibi olmuyor. Sorunu düzeltmek için Satır yükseklikleriyle ve sütun genişliklerini değiştirmeniz gerekir.

Şimdi baktım, örnek dosyanızda sayfayı 1 sayfaya sığdır seçeneği seçili, asıl dosyanızda ise bu seçili değil. Aynı şeyi asıl dosyanızda da yaparsanız sorun düzelir galiba.
Genişletmek için tıkla ...
İlginiz için teşekkürler Yusuf Bey
Benim yapmak istediğim de bu zaten, her sayfa için yazdırma alanını belirleyerek sığdır deyip yazdırmak. Ama bunu her sayfa için tek tek yapmamak adına bir kod aracılığıyla otomatik olsun istiyorum.
 
Yazdırmayla ilgili satırdan (içinde printout geçen satır) önce aşağıdaki kodu ilave edip dener misiniz:
Kod: 
With ActiveSheet.PageSetup
        .FitToPagesWide = 1
        .FitToPagesTall = 1
End With
 
YUSUF44' Alıntı:
Yazdırmayla ilgili satırdan (içinde printout geçen satır) önce aşağıdaki kodu ilave edip dener misiniz:
Kod: 
With ActiveSheet.PageSetup
        .FitToPagesWide = 1
        .FitToPagesTall = 1
End With
Genişletmek için tıkla ...

Vermiş olduğunuz kodu ilave ettim. 1. sayfayı doğru yazdırıyor ama 2. sayfayı yine aynı şekilde yazdırıyor. Kodları ilave ettiğim şekilde orjinal dosyayı tekrar ekliyorum. Bakabilirseniz sevinirim. Saygı ve selam ile...
 

Ekli dosyalar

Sayfa1'deki Komut düğmesinin kodlarını aşağıdaki şekle dönüştürüp 1-2. sayfaları ve 3-4. sayfaları ayrı ayrı denedim, her iki durumda da sayfaları bir sayfaya sığdırarak yazdı. Tabi her seferinde 14 sayfa yazdırmamak için kodlardaki kırmızı bölümü istediğim sayfalara göre değiştirdim.

Kod: 
Private Sub CommandButton1_Click()
Range("Q111,M136,BN8,BN10,BN12,BN14,BN16,BN22,BN24,BN26,BN28,BN30,BN36,BN38,BN40,BN42,BN44,DR7:DS37,EO24:FB33").Select
With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.708661417322835)
        .TopMargin = Application.InchesToPoints(0.393700787401575)
        .BottomMargin = Application.InchesToPoints(0.393700787401575)
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
Range("M4").Activate
ReDim yön(14)
ReDim yaz(14)

yön(1) = xlPortrait 'dikey
yön(2) = xlPortrait 'dikey
yön(3) = xlPortrait 'dikey
yön(4) = xlPortrait 'dikey
yön(5) = xlPortrait 'dikey
yön(6) = xlLandscape 'yatay
yön(7) = xlLandscape 'yatay
yön(8) = xlPortrait 'dikey
yön(9) = xlPortrait 'dikey
yön(10) = xlPortrait 'dikey
yön(11) = xlPortrait 'dikey
yön(12) = xlLandscape 'yatay
yön(13) = xlPortrait 'dikey
yön(14) = xlPortrait 'dikey


yaz(1) = "$A$3:$I$51"
yaz(2) = "$M$3:$V$72"
yaz(3) = "$M$74:$V$143"
yaz(4) = "$Z$3:$AK$64"
yaz(5) = "$AO$2:$BJ$55"
yaz(6) = "$BN$3:$CU$50"
yaz(7) = "$CY$2:$DT$49"
yaz(8) = "$DX$4:$EK$39"
yaz(9) = "$DX$59:$EK$93"
yaz(10) = "$DX$100:$EK$130"
yaz(11) = "$DX$138:$EK$166"
yaz(12) = "$EO$4:$FD$49"
yaz(13) = "$FH$3:$FK$57"
yaz(14) = "$FV$3:$FY$57"


adet = Application.InputBox("Yazdırmak İstiyormusunuz.", "Yazdırılacak kadar sayı giriniz.", "1", 400, 30, , Type:=1)
    
If adet = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If

For i = [COLOR=Red][B]1 To 14[/B][/COLOR]
ActiveSheet.PageSetup.Orientation = yön(i)
Worksheets(ActiveSheet.Name).PageSetup.PrintArea = yaz(i)
Worksheets(ActiveSheet.Name).PrintOut Copies:=adet, Collate:=True
Next i

End Sub
 
YUSUF44' Alıntı:
Sayfa1'deki Komut düğmesinin kodlarını aşağıdaki şekle dönüştürüp 1-2. sayfaları ve 3-4. sayfaları ayrı ayrı denedim, her iki durumda da sayfaları bir sayfaya sığdırarak yazdı. Tabi her seferinde 14 sayfa yazdırmamak için kodlardaki kırmızı bölümü istediğim sayfalara göre değiştirdim.
Genişletmek için tıkla ...

1. sayfada zaten bir sıkıntı yok. Sıkıntı 2. sayfada. Vermiş olduğunuz kodları 2. sayfaya uyarladım ama yine aynı şekilde yazdırıyor.
 
İkinci sayfa derken ben sayfa adı 1 olan sayfada (sheet) 2. sayfanın sığmadığını düşünerek cevap vermiştim. Halbuki siz sayfa adı 2 olan sayfa için soruyormuşsunuz.

Bunu çözmek için öncelikle 2. sayfadaki yazdıma alanını iptal ettim. Sonra Sayfa yapısından tümünü bir sayfaya sığdır2ı seçtim. Daha sonra kodları çalıştırdığımda problemsi olarak yazdırdı:

Kod: 
Private Sub CommandButton1_Click()
Range("M136,BN8,BN10,BN12,BN14,BN16,BN22,BN24,BN26,BN28,BN30,BN36,BN38,BN40,BN42,BN44,DR7:DS37,EO24:FB33").Select
With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.708661417322835)
        .TopMargin = Application.InchesToPoints(0.393700787401575)
        .BottomMargin = Application.InchesToPoints(0.393700787401575)
        .FitToPagesWide = 1
        .FitToPagesTall = 1
End With
Range("M4").Activate
ReDim yön(13)
ReDim yaz(13)

yön(1) = xlPortrait 'dikey
yön(2) = xlPortrait 'dikey
yön(3) = xlPortrait 'dikey
yön(4) = xlPortrait 'dikey
yön(5) = xlPortrait 'dikey
yön(6) = xlLandscape 'yatay
yön(7) = xlLandscape 'yatay
yön(8) = xlPortrait 'dikey
yön(9) = xlPortrait 'dikey
yön(10) = xlPortrait 'dikey
yön(11) = xlPortrait 'dikey
yön(12) = xlLandscape 'yatay
yön(13) = xlPortrait 'dikey


yaz(1) = "$A$3:$I$51"
yaz(2) = "$M$3:$V$72"
yaz(3) = "$M$74:$V$143"
yaz(4) = "$Z$3:$AK$64"
yaz(5) = "$AO$2:$BJ$55"
yaz(6) = "$BN$3:$CU$50"
yaz(7) = "$CY$2:$DT$49"
yaz(8) = "$DX$4:$EK$39"
yaz(9) = "$DX$59:$EK$93"
yaz(10) = "$DX$100:$EK$130"
yaz(11) = "$DX$138:$EK$166"
yaz(12) = "$EO$4:$FD$49"
yaz(13) = "$FV$3:$FY$57"


adet = Application.InputBox("Yazdırmak İstiyormusunuz.", "Yazdırılacak kadar sayı giriniz.", "1", 400, 30, , Type:=1)
    
If adet = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If

For i = 1 To 2
ActiveSheet.PageSetup.Orientation = yön(i)
Worksheets(ActiveSheet.Name).PageSetup.PrintArea = yaz(i)
Worksheets(ActiveSheet.Name).PrintOut Copies:=adet, Collate:=True
Next i
End Sub
 
YUSUF44' Alıntı:
İkinci sayfa derken ben sayfa adı 1 olan sayfada (sheet) 2. sayfanın sığmadığını düşünerek cevap vermiştim. Halbuki siz sayfa adı 2 olan sayfa için soruyormuşsunuz.

Bunu çözmek için öncelikle 2. sayfadaki yazdıma alanını iptal ettim. Sonra Sayfa yapısından tümünü bir sayfaya sığdır2ı seçtim. Daha sonra kodları çalıştırdığımda problemsi olarak yazdırdı:
Genişletmek için tıkla ...
Evimde yazıcı olmadığı için pazartesine kadar deneme şansım yok. Olumlu yada olumsuz mutlaka geri dönüş yapacağım.
Yalnız birşey sormak istiyorum.
For i = 1 To 2 satırının For i = 1 To 13 olması gerekmiyor mu?
Saygı ve selam ile ...
 
Öyle değiştirebilirsiniz. Ben 13 sayfa yazdırmamak için öyle yapıp sadece ilk 2 sayfayı yazdırdım.
 
YUSUF44' Alıntı:
İkinci sayfa derken ben sayfa adı 1 olan sayfada (sheet) 2. sayfanın sığmadığını düşünerek cevap vermiştim. Halbuki siz sayfa adı 2 olan sayfa için soruyormuşsunuz.

Bunu çözmek için öncelikle 2. sayfadaki yazdıma alanını iptal ettim. Sonra Sayfa yapısından tümünü bir sayfaya sığdır2ı seçtim. Daha sonra kodları çalıştırdığımda problemsi olarak yazdırdı:
Genişletmek için tıkla ...

Biraz uğraşarak en sonunda becerdim. Yardımlarınız için teşekkür ederim.
 
Merhaba arkadaşlar,
excel veya Word de ilk bir kaç sayfayı ( örneğin ilk 4 sayfa ) tek taraflı, sonraki sayfaları çift taraflı ve 300 adet yazdırmak istiyorum. Acaba bunun için bi makro butonunu nasıl oluşturacağım hakkında bana yardımcı olabilir misiniz? İlginize şimdiden teşekkürler...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst