• DİKKAT

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

makro ile yazdırma

Y

yaşar681

Katılım
19 Aralık 2007
Mesajlar
85
Excel Vers. ve Dili
2003
Private Sub CommandButton13_Click()
Dim adet As String, sayi As Byte
adet = InputBox("Yazdırılacak Miktarı Giriniz..:", "YAZDIRMA")
If Not IsNumeric(adet) Then Exit Sub
sayi = adet
Sheets("Sayfa2").Select
ActiveSheet.PageSetup.PrintArea = "A1:K60"
ActiveSheet.PrintOut Copies:=sayi, Collate:=True
End Sub



yukarda ki gibi sayfa2 ye makro giriyorum ama yazdır butonuna bastığımda sayfayı 8 e bölüyor yani 8 ayrı ayrı parça çıkarıyor bunu nasıl tek bütün sayfa olarak çıkarabilirim
 
kayıt makrosu kodlarından faydalanabilirsiniz diye düşünüyorum,


kod:
Private Sub CommandButton1_Click()
Dim adet As String, sayi As Byte
adet = InputBox("Yazdırılacak Miktarı Giriniz..:", "YAZDIRMA")
If Not IsNumeric(adet) Then Exit Sub
sayi = adet
Sheets("Sayfa2").Select
ActiveSheet.PageSetup.PrintArea = "A1:K60"
ActiveSheet.PrintOut Copies:=sayi, Collate:=True

Range("a1").Select
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With
ActiveWindow.SelectedSheets.PrintPreview
End Sub
 
teşekkür ederim ama

yazmış olduğunuz kodların hepsnimi yapıştıracağım
 
dediğim gibi kayıt makrosu çalıştırarak kodları aldım, aralarında mutlaka gereksiz olanlarda vardır, acil çözüm olsun için :) benim sayfamda işe yaradı, sizde eğer olmazsa sizde kayıt makrosu çalışırın, baskı önizleme alanında ayarla bölümündeki sığdır ı kullandığınızda bu kodları oluşturuyor, kendi sayfanızda aynı şeyi yapabilirsiniz
 
kod hata veriyor

Private Sub CommandButton1_Click()
Dim adet As String, sayi As Byte
adet = InputBox("Yazdırılacak Miktarı Giriniz..:", "YAZDIRMA")
If Not IsNumeric(adet) Then Exit Sub
sayi = adet
Sheets("Sayfa2").Select
ActiveSheet.PageSetup.PrintArea = "A1:K60"
ActiveSheet.PrintOut Copies:=sayi, Collate:=True

Range("a1").Select
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With
ActiveWindow.SelectedSheets.PrintPreview
End Sub
 
Sheets("Sayfa2").Select
With ActiveSheet.PageSetup
.PrintArea = "A1:K60"
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With
ActiveSheet.PrintOut Copies:=sayi, Collate:=True
Range("a1").Select

Şeklinde denerseniz olması lazım...
 
Ayrıca elimde; alıntı olan aşağıdaki kodlar var ve bir CommandButtona aktarıldığında Print için herşeyi yapabiliyorsunuz.

Sub PrintOnePage()
Dim wshTemp As Worksheet, wsh As Worksheet
Dim rngArr() As Range, c As Range
Dim i As Integer
Dim j As Integer

ReDim rngArr(1 To 1)
For Each wsh In ActiveWorkbook.Worksheets
i = i + 1
If i > 1 Then ' resize array
ReDim Preserve rngArr(1 To i)
End If

On Error Resume Next
Set c = wsh.Cells.SpecialCells(xlCellTypeLastCell)
If Err = 0 Then
On Error GoTo 0

'Prevent empty rows
Do While Application.CountA(c.EntireRow) = 0 _
And c.EntireRow.Row > 1
Set c = c.Offset(-1, 0)
Loop

Set rngArr(i) = wsh.Range(wsh.Range("A1"), c)
End If
Next wsh

'Add temp.Worksheet
Set wshTemp = Sheets.Add(after:=Worksheets(Worksheets.Count))

On Error Resume Next
With wshTemp
For i = 1 To UBound(rngArr)
If i = 1 Then
Set c = .Range("A1")
Else
Set c = _
ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)
Set c = c.Offset(2, 0).End(xlToLeft) ' skip one row
End If

'Copy-paste range (prevent empty range)
If Application.CountA(rngArr(i)) > 0 Then
rngArr(i).Copy c
End If
Next i
End With
On Error GoTo 0

Application.CutCopyMode = False ' prevent marquies

With ActiveSheet.PageSetup ' Fit to 1 page
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With

'Preview New Sheet
ActiveWindow.SelectedSheets.PrintPreview

'Print Desired Number of Copies
i = InputBox("Print how many copies?", "ExcelTips", 1)
If IsNumeric(i) Then
If i > 0 Then
ActiveSheet.PrintOut Copies:=i
End If
End If

'Delete temp.Worksheet?
If MsgBox("Delete the temporary worksheet?", _
vbYesNo, "ExcelTips") = vbYes Then
Application.DisplayAlerts = False
wshTemp.Delete
Application.DisplayAlerts = True
End If
End Sub
 
teşekkürler ama

ben bukodların hangisini kullanacam ayrıca kendi yazdığım kodun yanına mı yazacam
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst