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

[ياسر خليل أبو البراء]

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

إخواني وأحبابي في الله

لطالما أردت طرح هذا الموضوع الهام جداً والشيق جداً والمفيد جداً .. ولكن يبدو أن الزهايمر يلعب دوراً هاماً في حياتي ..

عموماً ذكرني عنوان موضوع رأيته الآن بهذا الموضوع ، فأحببت أن أشارككم هذا الكود الرائع والمتميز ..

الكود يقوم بالمهام التالية ..

في بداية تنفيذ الكود يمكنك الكود من اختيار الطابعة المطلوب الطباعة عليها .. من خلال الصور سأقوم بالطباعة على ملف بامتداد XPS .. حتى لا أهدر أوراقي (سامحوني .. دا مش بخل دا حرص مش كدا ولا ايه يا فلاحجي (لأنه أكتر واحد هيفهمني ))

حسناً رأيتم الصورة معبرة ..أليست كذلك؟ نقرنا على زر الأمر PRINT ...فظهرت نافذة تتيح لنا إمكانية اختيار الطابعة ثم نضغط أوك لننتقل للنافذة التالية

في النافذة التالية يتيح الكود كتابة عدد النسخ المراد طباعتها وبشكل افتراضي يكون عدد النسخ نسخة واحدة فقط ، ويمكن تغيير عدد النسخ المطلوبة

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

ثم أخيراً يتم تنفيذ أمر الطباعة ..في المثال الموضح سأقوم بتنفيذ أمر الطباعة لملف بامتداد XPS ..

حيث يتم كتابة اسم الملف وتحديد المسار الذي سيحفظ فيه الملف ثم اوك

قمت بتحديد مسار حفظ الملف بامتداد XPS على سطح المكتب

وها هو الملف وقد طبع ورقتي العمل Sheet1 و Sheet3 فقط ، لأنني حددتهما من خلال النوافذ التي تظهر

وأخيراً إليكم الكود الرائع الذي يقوم بكل هذه المهام الرائعة

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

تقبلوا جميعاً وافر تقديري واحترامي

 

حمل الملف من هنا

 

تحميلك للملف يدعم صاحب الموضوع .. فلا تبخل بدقيقة من وقتك .. وللعلم يمكنك عدم تحميل الملف ونسخ الكود في موديول في المصنف الخاص بك ، وستجد الكود جاهز للعمل لديك بدون تحميل الملف ..

دمتم على طاعة الله ...

[محي الدين ابو البشر]

السلام غليكم

واسعد الله صباحك

دائما مبدع 

أثابك الله خيرأً كثيراً

[محي الدين ابو البشر]

السلام عليكم 

اسناذ ياسر

عذراً منك لكني يبدو أني مشاكس 

ماذا لو اردنا أن نطبع عدد صفحات محدد أي نختار من sheet1  مثلاً 19 صفحة ومن sheet 2 4 صفحات وهكذا

بصراحة حاولت لكني اخفقت

اسف على الإزعاج

بارك الله بك ولك وجرزالك الله كل خير

[ابوعبدالواجد]

جزيت خيرا

كود ممتاز

وسع الله عليك بالعلم والفضل

 

[جلال الجمال_ابو أدهم]

بارك الله فيك و جزاك خيرا
كود محترم من انسان اقل وصف له انه انسان بمعنى الكلمه

[saad abed]

12 ساعات مضت, ياسر خليل أبو البراء said:

تحميلك للملف يدعم صاحب الموضوع .. فلا تبخل بدقيقة من وقتك .. وللعلم يمكنك عدم تحميل الملف ونسخ الكود في موديول في المصنف الخاص بك ، وستجد الكود جاهز للعمل لديك بدون تحميل الملف ..

اخى ابوالبرء

وفقكم الله لما يحب

والله حاولت تحميل الملف اكثر من مره الرابط به مشكله

كيف لا ندعم من لم يبخل علينا بمجهوده وشروحاته معاك في اى مكان

[جلال الجمال_ابو أدهم]

11 دقائق مضت, سعد عابد said:

اخى ابوالبرء

وفقكم الله لما يحب

والله حاولت تحميل الملف اكثر من مره الرابط به مشكله

كيف لا ندعم من لم يبخل علينا بمجهوده وشروحاته معاك في اى مكان

تحياتى لك استاذنا / سعد عابد
تم تحميل الملف بنجاح عن طريق كابس على SKIP 
اعلى الصفحه على اليمن بعد فتح كل نافذه
تحياتى

[ياسر خليل أبو البراء]

أخي العزيز محي الدين

بارك الله فيك على مرورك العطر .. وبالنسبة لطلبك مختلف بعض الشيء عن الموضوع ، يمكنك طرح موضوع مستقل ، وإن شاء الله إذا تيسر لي الوقت سأحاول الاشتراك في تقديم حل مع الأخوة الأعضاء

أخي الكريم أبو عبد الواجد

جزيت خيراً على مرورك العطر وعلى دعائك الطيب

أخي الفاضل جلال الجمال

بارك الله فيك وجزيت خيراً على مرورك العطر وتشجيعك لي

أخي الحبيب سعد عابد

إذا كنت تعاني من التحميل فلا عليك يمكنك نسخ الكود ووضعه في موديول واستخدامه في أي ملف .. الكود مرن جداً

تقبلوا جميعاً تحياتي

[saad abed]

اخوانى

اشكركم جربت الان فتم الدخول للموقع وتم التحميل

اخى ياسر

الكود امامى ولكن انا تلميذ باسمع الكلام عايز احمل من المكان اللى حدده الاستاذ

[ياسر خليل أبو البراء]

ربنا يبارك فيك أخي الحبيب سعد عابد وإن شاء الله تكون استفدت من الموضوع

شرفني مرورك العطر بالموضوع .. والحمد لله أن تم المطلوب على خير

تقبل تحياتي

[رمضان بكري2015]

تسلم ايدك استاذنا الفاضل 
لك كل الاحترام والتقدير

أ/ ياسر 

[عامر ياسر]

ابدعت استاذنا الكريم زادك الله علما ً  

[رمضان بكري2015]

السلام عليكم 
استاذنا الفاضل ياسر خليل
دئما متألق  في VBA
انا حولت لكن يعمل الزر بحالة جيدة ولصق الكود 
لكن لدي مشكلة عند الطباعة يقسم الورقة الي 3 اعمدة 
رغم الفاتورة حوالي 30 صف 
ما هو الحل 

 

[صلاح الصغير]

كم انت رائع عزيزى / ياسر

[ياسر خليل أبو البراء]

بارك الله فيكم إخواني وأحبابي في الله

أخي رمضان

جرب تضع فواصل للصفحات المراد طباعتها .. إذا استمرت المشكلة يرجى إرفاق ملف مع توضيح المشكلة بالصور لتتضح بشكل تام

تقبلوا تحياتي

[Mr. shehata]

شكرا جزيلا لك جزاك الله خيرا