تعديل كود طباعة راس وتذييل الصفحة الى صفحات فردية وزوجية مختلفة

[مصطفى محمود مصطفى]

السلام عليكم

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

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

شكرا للجميع وبارك الله في جهودكم الطيبة

(Private Sub Workbook_BeforePrint(Cancel As Boolean)
With ActiveSheet.PageSetup
    .RightHeader = Sheets("Sheet1").Range("A1").Value & Chr(13) & Sheets("Sheet1").Range("A2").Value
    .CenterHeader = Sheets("Sheet1").Range("b1").Value & Chr(13) & Sheets("Sheet1").Range("b2").Value
    .LeftHeader = Sheets("Sheet1").Range("c1").Value & Chr(13) & Sheets("Sheet1").Range("c2").Value
    .RightFooter = Sheets("Sheet1").Range("A3").Value & Chr(13) & Sheets("Sheet1").Range("A4").Value
    .CenterFooter = Sheets("Sheet1").Range("b3").Value & Chr(13) & Sheets("Sheet1").Range("b4").Value
    .LeftFooter = Sheets("Sheet1").Range("c3").Value & Chr(13) & Sheets("Sheet1").Range("c4").Value
End With
End Sub)

 

صفحات فردية وزوجية مختلفة.rar

[الـعيدروس]

ارفق مثال عملي لما تريد

كما الملف عندك وحط بيانات وهميه

 ليتم التطبيق عليه مع شرح مبسط

تحياتي

[مصطفى محمود مصطفى]

شكرا لكم استاذ العيدروس  للاستجابة السريعة جزاكم الله خيرا

ارفقت ملف وفيه شرح بسيط ان شاء الله تصل الفكرة التي اريد الوصول اليها

بارك الله في جهودكم الطيبة

 

 

راس وتذييل الصفحة.rar

[الـعيدروس]

السلام عليكم

جرب هذا الكود

Sub Ali_Prnt()
Dim R           As Long
Dim Num         As Long
'**********************************************
On Error Resume Next
With ActiveSheet
    .PageSetup.PrintArea = .PageSetup.PrintArea
    ActiveWindow.View = xlPageBreakPreview
     For R = 1 To .HPageBreaks.Count + 1
        Num = Num + 1
        If Num Mod 2 <> 0 Then
            With .PageSetup
                 .RightHeader = Sheets("الاساسية").Range("A1").Value & Chr(13) & Sheets("الاساسية").Range("A2").Value
                 .RightFooter = Sheets("الاساسية").Range("A3").Value & Chr(13) & Sheets("الاساسية").Range("A4").Value
                 .CenterFooter = Sheets("الاساسية").Range("b3").Value & Chr(13) & Sheets("الاساسية").Range("b4").Value
            End With
                .PrintPreview
        Else
            With .PageSetup
                 .LeftHeader = Sheets("الاساسية").Range("c1").Value & Chr(13) & Sheets("الاساسية").Range("c2").Value
                 .LeftFooter = Sheets("الاساسية").Range("c3").Value & Chr(13) & Sheets("الاساسية").Range("c4").Value
            End With
                .PrintPreview
            End If
        Next R
End With
    ActiveWindow.View = xlNormalView
'**********************************************
On Error GoTo 0
End Sub

لاتنسى تحط علامة ' في كود حدث الطباعة 

'Private Sub Workbook_BeforePrint(Cancel As Boolean)
'With ActiveSheet.PageSetup
'' على خليتين لكل واحدة يعني يمين خليتين يسار خليتين وسط خليتين لتذيل وراس الصفحة
'    .RightHeader = Sheets("الاساسية").Range("A1").Value & Chr(13) & Sheets("الاساسية").Range("A2").Value
'    .CenterHeader = Sheets("الاساسية").Range("b1").Value & Chr(13) & Sheets("الاساسية").Range("b2").Value
'    .LeftHeader = Sheets("الاساسية").Range("c1").Value & Chr(13) & Sheets("الاساسية").Range("c2").Value
'    .RightFooter = Sheets("الاساسية").Range("A3").Value & Chr(13) & Sheets("الاساسية").Range("A4").Value
'    .CenterFooter = Sheets("الاساسية").Range("b3").Value & Chr(13) & Sheets("الاساسية").Range("b4").Value
'    .LeftFooter = Sheets("الاساسية").Range("c3").Value & Chr(13) & Sheets("الاساسية").Range("c4").Value
'End With
'End Sub

تحياتي

تم تعديل نوفمبر 17, 2015 بواسطه الـعيدروس

[مصطفى محمود مصطفى]

السلام عليكم

اخي الاستاذ العيدروس جزاكم الله خيرا

شكرا لكم على جهودكم ووقتكم الكود رائع

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

يظهر لي في الصفحة الفرديةفي الرأس فقط المدرسة ولا يظهر جدول رقم 1 من الخلية B1-B2

اما تذييل الورقة الفردية يظهر كاملا ولا يوجد فيه خلل

اما راس وتذييل الصفحة الزوجية لايظهر فيها اي بيانات

بارك الله لكم في ذريتكم ورزقكم

تحياتي 

 

 

تنفيذ الكود راس وتذييل الصفحة.rar

[الـعيدروس]

جرب هذا التعديل

هذا التعديل بيتماشي مع ملفك كما هو بوضعه الحالي

Dim Sh As Worksheet
Sub Ali_Prnt()
Dim R           As Long
Dim Ar
Dim Rn As Range, Rn1 As Range
Set Sh = ActiveSheet
'**********************************************
On Error Resume Next
Application.EnableEvents = True
With Sh
II = .PageSetup.PrintArea
For R = 1 To .VPageBreaks.Count
Ro = .VPageBreaks(R).Location.Row
Cl = .VPageBreaks(R).Location.Column
Ar = .Range(.PageSetup.PrintArea)
Lr = UBound(Ar, 2) + 1
Rw = UBound(Ar, 1) + 1
Set Rn = .Range(Cells(Ro, 2), Cells(Rw, Cl - 1))
Set Rn1 = .Range(Cells(Ro, Cl), Cells(Rw, Lr))
            Ali_Rest
            With .PageSetup
                 .PrintArea = Rn.Address
                 .RightHeader = Sheets("الاساسية").Range("A1").Value & Chr(13) & Sheets("الاساسية").Range("A2").Value
                 .LeftHeader = Sheets("الاساسية").Range("B1").Value & Chr(13) & Sheets("الاساسية").Range("B2").Value
                 .RightFooter = Sheets("الاساسية").Range("A3").Value & Chr(13) & Sheets("الاساسية").Range("A4").Value
                 .CenterFooter = Sheets("الاساسية").Range("b3").Value & Chr(13) & Sheets("الاساسية").Range("b4").Value
                    End With
                .PrintPreview
            Ali_Rest
            With .PageSetup
                 .PrintArea = Rn1.Address
                 .LeftHeader = Sheets("الاساسية").Range("c1").Value & Chr(13) & Sheets("الاساسية").Range("c2").Value
                 .LeftFooter = Sheets("الاساسية").Range("c3").Value & Chr(13) & Sheets("الاساسية").Range("c4").Value
            End With
                .PrintPreview
        Next R
        .PageSetup.PrintArea = II
End With
Application.EnableEvents = False
'**********************************************
On Error GoTo 0
End Sub
Private Sub Ali_Rest()
With Sh
    With .PageSetup
            .RightHeader = ""
            .RightFooter = ""
            .CenterFooter = ""
            .LeftHeader = ""
            .LeftFooter = ""
    End With
End With
Set Sh = Nothing
End Sub

 

[مصطفى محمود مصطفى]

السلام عليكم

اخي الاستاذ العيدروس وفقكم الله وانا تعبتك معاي  واخذت من وقتك وجهدك الكثير

الله يعطيك الف عافية هذ التعديل ممتاز سلمت يمينك

ارجو من حضرتكم اذا ممكن والله ما بدي اغلبك لكن قدر المستطاع من وقتكم وجهدكم

الكود يعمل بشكل صحيح وددت ان شاء الله تعديل بسيط وهو

الورقة الفردية تمام وتسلم ايدك لكن الورقة الزوجية تكرر فيها اسم المدرسة في الراس وتكرر في التذييل اعداد التلاميذ وعدد الشعب

فاذا امكن عافاكم الله التعديل بعدم تكرار بيانات  الصفحة الفردية في الصفحة الزوجية

لكم تحياتي

 

التكرارفي الصفحةالزوجية.rar

تم تعديل نوفمبر 19, 2015 بواسطه مصطفى محمود مصطفى

[الـعيدروس]

السلام عليكم

لا عليك اخي مصطفى محمود

نحن بالخدمة طالما السؤال في حدود المعرفه

 جرب المرفق

التكرارفي الصفحةالزوجية_111.rar

[مصطفى محمود مصطفى]

السلام عليكم

اخي الاستاذ العيدروس (ابو نصار ) بارك الله في علمكم وزادكم علما ومعرفة

الله يعطيك الصحة والعافية ويرفع مقامكم

الكود اكثر من رائع

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

لكم تحياتي

تم تعديل نوفمبر 19, 2015 بواسطه مصطفى محمود مصطفى

[مصطفى محمود مصطفى]

السلام عليكم

اخي الاستاذ ابو نصار

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

حملت فيديو لمشاهدة الحالة وابداء المساعدة

شاكر لكم تعاونكم معي وصبركم

وفقكم الله

http://a7lashare.com/download/be77a7bf33.html

 

تم تعديل نوفمبر 20, 2015 بواسطه مصطفى محمود مصطفى

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

أخي الكريم مصطفى

صراحة لم أتابع الموضوع منذ البداية ولكن اطلعت على ملف أخي الحبيب أبو نصار .. واطلعت على سؤالك الأخير بخصوص أن أوراق الطباعة أكثر من صفحتين

روح للتبويب View ثم اختر الأمر Page Break Preview ستجد خطوط زرقاء سميكة يمكنك من خلالها التحكم في الصفحات المطلوب طباعتها ..قم بسحب هذه الخطوط بحيث يتناسب مع طلبك

أرجو أن يكون المطلوب

 

[مصطفى محمود مصطفى]

السلام عليكم

اخي الاستاذ ابو البراء حفظكم الله

قمت بعمل المطلوب كما شرحت وغيرته اكثر من مرة

لم تضبط معي عندما اشغل الكود تتغير اعدادات المعاينة كما في الفيديو المرفق

اما اذا عملتها يدوي يطبع صفحتين تمام ودون زيادة

اعتقد الكود يلغي معاينة الطباعة التي اعملها ويبدا من جديد

وكما تعلم استاذي انا اردت طباعة راس وتذييل الصفحات فردية تختلف عن الزوجية

لذلك قام الاستاذ ابو نصار بارسال الكود وهو رائع يقوم بادراج راس وتذييل الصفحة الفردية والزوجية تمام كما مطلوب

لكنه لايتوقف وانما يستمر حتى بعد اكمال الطباعة

شكرا للمداخلة ونامل مساعدتي مع الاستاذ ابو نصار اذا امكن لكم ذلك

تحياتي

تم تعديل نوفمبر 20, 2015 بواسطه مصطفى محمود مصطفى

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

قم بضبط منطقة الطباعة Print Area >> من خلال التبويب Page Layout ثم Print Area ثم حدد النطاق المطلوب العمل عليه ..

لا أدري ما المشكلة لديك ولا يمكن التخمين لأبعد من هذا الحد

إذا استمرت المشكلة يرجى إرفاق ملفك الأصلي بعد مسح البيانات الحساسة التي بالملف الأصلي

تقبل تحياتي

 

[مصطفى محمود مصطفى]

السلام عليكم

اشكرك جزيل الشكر استاذ ياسر وبارك الله بك

ارفق الملف وفيه الكود وتعديل بسيط في الخلايا المطلوب ظهورها في الراس والتذييل مع اضافة كود

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

وان شاء الله ساجد عندكم او عند الاستاذ ابو نصار جزاه الله خيرا حلا للمشكلة

لكم تحياتي جميعا

 

طباعة راس وتذيل الصفحات الفردية والزوجية.rar

[الـعيدروس]

اذا كان ملفك كجدول واحد الغي الحلقه التكراريه ليصبح الكود كالتالي

Sub Ali_Prnt()
Dim R           As Long
Dim Ar
Dim Rn As Range, Rn1 As Range
Dim Sh As Worksheet
'**********************************************
Call YK_Start
On Error Resume Next
Set Sh = ActiveSheet
With Sh
II = .PageSetup.PrintArea
'For R = 1 To .VPageBreaks.Count
Ro = .VPageBreaks(1).Location.Row
Cl = .VPageBreaks(1).Location.Column
Ar = .Range(.PageSetup.PrintArea)
Lr = UBound(Ar, 2) + 1
Rw = UBound(Ar, 1) + 1
Set Rn = .Range(Cells(Ro, 2), Cells(Rw, Cl - 1))
Set Rn1 = .Range(Cells(Ro, Cl), Cells(Rw, Lr))
            Ali_Rest
            With .PageSetup
                 .PrintArea = Rn.Address
                 .RightHeader = Sheets("الاساسية").Range("A5").Value & Chr(13) & Sheets("الاساسية").Range("B5").Value
                 .LeftHeader = Sheets("الاساسية").Range("A7").Value & Chr(13) & Sheets("الاساسية").Range("B7").Value
                 .RightFooter = Sheets("الاساسية").Range("A10").Value & Chr(13) & Sheets("الاساسية").Range("B10").Value
                 .CenterFooter = Sheets("الاساسية").Range("A11").Value & Chr(13) & Sheets("الاساسية").Range("b11").Value
            End With
                .PrintPreview
            Ali_Rest
            With .PageSetup
                 .PrintArea = Rn1.Address
                 .LeftHeader = Sheets("الاساسية").Range("A8").Value & Chr(13) & Sheets("الاساسية").Range("B8").Value
                 .LeftFooter = Sheets("الاساسية").Range("B6").Value & Chr(13) & Sheets("الاساسية").Range("A6").Value
                 .CenterHeader = Sheets("الاساسية").Range("A9").Value
            End With
                .PrintPreview
            Ali_Rest
'        Next R
        .PageSetup.PrintArea = II
End With
Set Sh = Nothing
Call YK_End
'**********************************************
On Error GoTo 0
End Sub
Private Sub Ali_Rest()
Call YK_Start
With Sheets("عام")
    With .PageSetup
            .LeftHeader = ""
            .RightHeader = ""
            .CenterHeader = ""
            .LeftFooter = ""
            .RightFooter = ""
            .CenterFooter = ""
    End With
End With
Call YK_End
End Sub

 

[مصطفى محمود مصطفى]

السلام عليكم

الاخ الاستاذ ابو نصار

كود ممتاز ويعمل بشكل رائع على ملفي الاصلي

جعله الله في ميزان حسناتكم

وفقكم الله واعطاكم الصحة والعافية وحفظكم من كل سوء

تحياتي