محتاج كود طباعة

[2saad]

إخواني الأعزاء بعد سلام الله عليكم ورحمة الله وبركاته

لدي ثلاث ورقات من النطاق A1  الي R150

الورقة الأولي من A1 الي R46

الورقة الثانية من A47 الي R96

الورقة الثالثة من A97 الي R150

محتاج كود طباعة الثلاث ورقات دفعة واحدة بحيث الورقة الأولي والثالثة اطبع نسخة واحدة والورقة الثانية اطبع 4 نسخ

ولكم جزيل الشكر

[محمد هشام.]

جرب هدا 

Sub PrintArea()
Dim F As Worksheet: Set F = Sheet1
 
Cpt = 18:   A = 1:    B = 4:     C = 1
 
 With F
 
   .PageSetup.PrintArea = ""
   .PageSetup.PrintArea = Range("A1", Cells(46, Cpt)).Address: .PrintOut Copies:=A
   .PageSetup.PrintArea = Range("A47", Cells(96, Cpt)).Address: .PrintOut Copies:=B
   .PageSetup.PrintArea = Range("A97", Cells(150, Cpt)).Address: .PrintOut Copies:=C
 
 End With
End Sub

او يمكنك تحديد الصفحات وعدد مرات الطباعة بالاعتماد على ورقة اخرى خاصة بالاعدادات كما في المثال التالي 

Public Property Get Sh_Print() As Worksheet: Set Sh_Print = Sheet1
End Property
Public Property Get F() As Worksheet: Set F = Sheet2
End Property
Sub To_print()
     déleteRow
     TbPage = F.[Tb_MiseEnPage]
     NbMax = UBound(TbPage)
     Cpt = Application.InputBox(Prompt:=" المرجوا ادخال رقم  الصفحة المرغوب طباعتها (من 0  الى " & NbMax & ")", Title:="طباعة", Type:=1)
     Cpt = Int(Cpt)
    If Cpt < 1 Then Exit Sub
     If Cpt > NbMax Then:  MsgBox "   اخر صفحة على الملف هي : " _
           & NbMax _
           & "", vbExclamation, "المرجوا التحقق من رقم الصفحة المرغوب طباعتها": Exit Sub
 With Sh_Print
    .PageSetup.PrintArea = ""
     For i = 1 To Cpt
          With .PageSetup
          On Error Resume Next
               .PrintArea = TbPage(i, 2) & ":" & TbPage(i, 3): Copies = TbPage(i, 4)
                If Copies < 1 Then Copies = 1
               .FitToPagesWide = 1
               .FitToPagesTall = 1
               On Error GoTo 0
        End With
     Next
 End With
    Sh_Print.PrintOut Copies:=Copies
End Sub
'***********************************                            
Sub déleteRow()
 With F
  For i = F.[B65000].End(xlUp).Row To 2 Step -1
  Application.ScreenUpdating = False
     If Application.CountA(Range(F.Cells(i, "B"), F.Cells(i, "C"))) = 0 Then F.Rows(i).Delete
     F.Range("A2:A" & Rows.Count).ClearContents
  Next i
With F.Range("A2:A" & F.Cells(Rows.Count, "B").End(xlUp).Row)
            .Value = Evaluate("ROW(" & .Address & ")-1")
     End With
 End With
Application.ScreenUpdating = True
End Sub

 

نمودج طباعة.xlsm

[2saad]

بارك الله فيك وجعله في ميزان حسنانك