Soru Yazdır Kopya Adedi

[Hsn55]

İyi günler,
ekli dosyada ana sayfada yazdır butonu ile I3:I10 arasında yazdırılacak sayfaları seçtiğimde J3:J10 hücreleri arasındaki sayfaları aşağıdaki makro ile yazdırıyorum. Benim istediğim yazdır butonunu tıkadığımda ekli resimdeki gibi kutucuğa yazdırma adedini girip ,girilen adet kadar seçili sayfaların yazdırılması. Bu konu da bana destek olursanız sevinirim.
Makro:

Sub Secili_Sayfalari_Yazdir()
    Sayfa1.Gizle
    Dim Onay As Byte, Sayfa As Range
 
    
    Onay = MsgBox("Seçtiğiniz sayfaları yardırmak istediğinize emin misiniz?", vbExclamation + vbYesNo + vbDefaultButton2)
    
    If Onay = vbNo Then Exit Sub
    If WorksheetFunction.CountA(Sheets("ANA SAYFA").Range("I3:I10")) = 0 Then
        MsgBox "Yazdırma işlemi için önce sayfa seçimi yapmalısınız!", vbCritical
        
        Exit Sub
    
    End If
 
    For Each Sayfa In Sheets("ANA SAYFA").Range("I3:I10")
        If Sayfa.Value <> "" Then Sheets(CStr(Sayfa.Offset(, 1).Value)).PrintOut
    
    Next
   Sheets("ANA SAYFA").Select

    
End Sub

İndir TEKLİF PROGRAMI xlsm

Dosyayı indir TEKLİF PROGRAMI xlsm

dosya.co

 

[Muzaffer Ali]

Merhaba.

Sub Secili_Sayfalari_Yazdir()
    Sayfa1.Gizle
    Dim Onay As Byte, Sayfa As Range
    Dim KopyaSayisi As Variant
    
    Onay = MsgBox("Seçtiğiniz sayfaları yardırmak istediğinize emin misiniz?", vbExclamation + vbYesNo + vbDefaultButton2)
    If Onay = vbNo Then Exit Sub
    If WorksheetFunction.CountA(Sheets("ANA SAYFA").Range("I3:I10")) = 0 Then
        MsgBox "Yazdırma işlemi için önce sayfa seçimi yapmalısınız!", vbCritical
        Exit Sub
    End If
0:
    KopyaSayisi = InputBox("Kopya sayısı giriniz.")
    If KopyaSayisi = "" Then
        MsgBox "İşelm iptal edildi."
    ElseIf Not IsNumeric(KopyaSayisi) Then
        MsgBox "Lütfen bir sayı giriniz."
        GoTo 0
    End If
 
    For Each Sayfa In Sheets("ANA SAYFA").Range("I3:I10")
        If Sayfa.Value <> "" Then Sheets(CStr(Sayfa.Offset(, 1).Value)).PrintOut Copies:=KopyaSayisi
    Next
   Sheets("ANA SAYFA").Select
End Sub

 

[Hsn55]

Muzaffer bey merhabalar;
Şu satırda hata veriyor. Ayrıca "Seçili Sayfaları yazdırmak istediğinizden emin misiniz."Uyarısını kaldırabilir misiniz. Sadece Butona basınca Kopya sayısı gelsin. Ok/Cansel deyince işlem yapsın .Birde kopya adedi kutucuğu "2" Adet gelebilir mi?

  If Sayfa.Value <> "" Then Sheets(CStr(Sayfa.Offset(, 1).Value)).PrintOut Copies:=KopyaSayisi

 

[Hsn55]

Merhaba.

Sub Secili_Sayfalari_Yazdir()
    Sayfa1.Gizle
    Dim Onay As Byte, Sayfa As Range
    Dim KopyaSayisi As Variant
   
    Onay = MsgBox("Seçtiğiniz sayfaları yardırmak istediğinize emin misiniz?", vbExclamation + vbYesNo + vbDefaultButton2)
    If Onay = vbNo Then Exit Sub
    If WorksheetFunction.CountA(Sheets("ANA SAYFA").Range("I3:I10")) = 0 Then
        MsgBox "Yazdırma işlemi için önce sayfa seçimi yapmalısınız!", vbCritical
        Exit Sub
    End If
0:
    KopyaSayisi = InputBox("Kopya sayısı giriniz.")
    If KopyaSayisi = "" Then
        MsgBox "İşelm iptal edildi."
    ElseIf Not IsNumeric(KopyaSayisi) Then
        MsgBox "Lütfen bir sayı giriniz."
        GoTo 0
    End If

    For Each Sayfa In Sheets("ANA SAYFA").Range("I3:I10")
        If Sayfa.Value <> "" Then Sheets(CStr(Sayfa.Offset(, 1).Value)).PrintOut Copies:=KopyaSayisi
    Next
   Sheets("ANA SAYFA").Select
End Sub

Muzaffer bey teşekkür ederim. Diğer talebimi hallettim. Konu çözüme kavuşmuştur. Hayırlı akşamlar