كود طباعة صفحات محددة Select Printer & Print Specific Sheets

السلام عليكم ورحمة الله وبركاته

أقدم لكم كود يمكنك من طباعة صفحات محددة في المصنف ، كما يمكنك تحديد عدد النسخ المراد طباعتها ، كما يمكنك تحديد نوع الطابعة المراد الطباعة عليها

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

سأترك لكم الصور لمعرفة كيفية التعامل مع الكود 

وإليكم الكود المستخدم لتنفيذ الفكرة

Sub PrintSelectedSheets()
    Dim I As Integer
    Dim TopPos As Integer
    Dim SheetCount As Integer
    Dim PrintDlg As DialogSheet
    Dim CurrentSheet As Worksheet
    Dim Cb As CheckBox
    Dim Numcop As Long
    Dim Cnt As Integer
    Dim X As String
    
    Application.Dialogs(xlDialogPrinterSetup).Show
    
    Application.ScreenUpdating = False
        If ActiveWorkbook.ProtectStructure Then
            MsgBox "المصنف محمي", vbCritical
            Exit Sub
        End If
    
        Set CurrentSheet = ActiveSheet
        X = CurrentSheet.Name
        Set PrintDlg = ActiveWorkbook.DialogSheets.Add
        SheetCount = 0
    
        TopPos = 40
        For I = 1 To ActiveWorkbook.Worksheets.Count
            Set CurrentSheet = ActiveWorkbook.Worksheets(I)
    
            If Application.CountA(CurrentSheet.Cells) <> 0 And CurrentSheet.Visible Then
                SheetCount = SheetCount + 1
                PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5
                PrintDlg.CheckBoxes(SheetCount).Text = CurrentSheet.Name
                TopPos = TopPos + 13
            End If
        Next I
    
        PrintDlg.Buttons.Left = 240
    
        With PrintDlg.DialogFrame
            .Height = Application.Max(68, PrintDlg.DialogFrame.Top + TopPos - 34)
            .Width = 230
            .Caption = "اختر أوراق العمل المراد طباعتها"
        End With
    
        PrintDlg.Buttons("Button 2").BringToFront
        PrintDlg.Buttons("Button 3").BringToFront
    
        Numcop = Application.InputBox("أدخل عدد النسخ للطباعة:", "كم عدد النسخ?", 1, Type:=1)
        If Numcop = 0 Then
        ElseIf Len(Numcop) > 0 Then
        End If
    
        CurrentSheet.Activate
    Application.ScreenUpdating = True

    If SheetCount <> 0 Then
        If PrintDlg.Show Then
            For Each Cb In PrintDlg.CheckBoxes
                If Cb.Value = xlOn Then
                    If Cnt = 0 Then
                        Worksheets(Cb.Caption).Select
                    Else
                        Worksheets(Cb.Caption).Select Replace:=False
                    End If
                    Cnt = Cnt + 1
                End If
            Next Cb
            ActiveWindow.SelectedSheets.PrintOut copies:=Numcop

        End If
    Else
        MsgBox "كل أوراق العمل فارغة", 64
    End If

    Application.DisplayAlerts = False
    PrintDlg.Delete

    Sheets(X).Select
End Sub

تحميل الملف من هنا

إعداد / ياسر خليل أبو البراء