طلب كود لحل مشكلة تذيل صفحات اوراق العمل

[أبو سجده]

بسم الله الرحمن الرحيم

وبه نستعين

الساده الزملاء الافاضل

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

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

داعيا المولى العلى القديرأن يتقبل منا جميعا صالح الاعمال

انه ولى ذلك والقادرعليه

تناول معظم الساده الزملاء الآفاضل بمنتدانا المتألق دوما

موضوع تذيل اوراق العمل

  ومن خلال تنوع الافكارالتى قدمتومها حضراتكم

تبين أن المشكلة مازلت قائمة حيث يعتمد

موضوع التذيل على عدة عوامل أهمها

ان يكون التذيل أسفل الجدول مباشرة سواء فى المطبوعات التجارية كالفواتير

 وايضا المطبوعات الحكومية ككشوف صرف المكافات

والتى تعتمد على عدة توقيات فضلا عن عملية التفقيط  فلابد

من وجود فراغ ملائم ليحتوى على توقيعات الساده المسؤلون

بالاضافة الى الاختام المطلوبه لاعتماد عملية الصرف

فهناك فكرة ارجو من الله تعالى أن تكون موفقه لخدمة الجميع

لذا نرجو من حضراتكم فضلا

ان تساهموا فى تنفيذ هذه الفكرة لعلها تكون فيها النفع والافاده

تعتمد فكرة الكود المطلوب على

إدراك عدد 5 صفوف من بداية الصف الـــ 29

ثم نسخ محتوى التذيل المطلوب نسخة من الورقة "DATA" الى الورقة " مكافاة الثانويه العامه"

ثم نسخ عدد 21 صف بنفس التنسيقات والمعادلات بداية من الـــ 8 الى 28 وهكذا

وذلك من خلال فوروم بسيط يحتوى على الاوامرالتاليه

 ادرك الصفوف اولا

ثم رساله " هل تريد نسخ محتوى التذيل المطلوب"

 ثم نعم

 ثم رساله أخرى " هل تريد نسخ الصفوف من 8 الى 28 "

ثم نعم

او كما تروه سيادتكم  فضلا ملائما لتنفيذ هذه المحاولة  

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

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

تم تعديل أغسطس 25, 2014 بواسطه سعيد بيرم

[اسلام سيد]

السلام عليكم

 

استاذ / سعيد بيرم

 

جزاكم الله خير ودام الله عليكم العلم النافع

[احمدزمان]

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

 

بعد الإطلاع على طلب اخونا الحبيب سعيد بيرم

 

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

وذلك بعمل نموذج نحدد فية

- عدد الصفوف لكل ورقة

- ارقام صفوف الرأس

- ارقام صفوف التذييل

ثم باستخدام التصفية التلقائية مع الدوال و كود اخفاء و اظهار يتم الوصول للشكل المطلوب

 

هذه الفكرة التي يمكن تنفيذها اذا وافقت عليها

[أبو سجده]

اخى الحبيب الغالى المحترم الحاج // احمد يعقوب

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

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

اخى الحبيب ولما لاأوافق على فكرة سيادتكم 

فتعدد الافكاروالاراء تأتى دائما بما يجول فى أذهاننا

فسرعلى بركة الله... وسيسير معنا الساده الزملاء الافاضل

والله المستعان 

تقبل وافراحترامى وتقديرى

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

تم تعديل أغسطس 26, 2014 بواسطه سعيد بيرم

[أبو سجده]

اخوانى الاعزاء الافاضل

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

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

كثيرمن مشاكل تذيل ورقة العمل وخاصة

اذا كانت ظروف العمل تتطلب طباعة كميات

كبيرة من كشوف الصرف التى تصل فى بعض الاحيان

الى مئات الصفحات للأمرالواحد

تقبلوا وافراحترامى وتقديرى

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

تم تعديل أغسطس 26, 2014 بواسطه سعيد بيرم

[شوقي ربيع]

السلام عليكم

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

اما الحل هو فقط اضغط  على  F2 وشاهد بنفسك

تحياتي

فكرة جديده للتخلص من مشكلة تذيل صفحات اوراق العمل - سعيد بيرم.rar

[احمدزمان]

السلام عليكم

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

اما الحل هو فقط اضغط  على  F2 وشاهد بنفسك

تحياتي

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

[أبو سجده]

اخى العزيز الفاضل المحترم الاستاذ// شوقى ربيع

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

تنفيذ أكثر من رائع من شخصية رائعه

بارك الله فيكم وفى ذريتكم واسمح لى ببعض الاضافات

حتى يكتمل الموضوع والكمال لله وحده

وتنحصر تلك الاضافات أن أمكن ذلك وبحول الله تعالى ستكتمل

على يديكم الكريمه اولا بشأن ارتفاع الصفوف من 8 الى 28 = 40

ومع نسخ تلك الصفوف يتحول الارتفاع الى 35.25

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

نظرا لظهور اختلاف فى فواصل الصفحات

أو بالاحرى جعل فواصل الصفحات ثابته مع نهاية التذيل المطلوب

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

تم تعديل أغسطس 26, 2014 بواسطه سعيد بيرم

[احمدزمان]

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

بالإضافة للحل الرائع الذي قدمة الأستاذ شوقي

 

هذا حل آخر حسب الفكرة السابقة التي ذكرتها

عبيء بيانات النموذج ثم اضغط طباعة التقرير

 

فكرة جديده للتخلص من مشكلة تذيل صفحات اوراق العمل - سعيد بيرم.rar

[شوقي ربيع]

السلام عليكم

 

 

فكرة جديده للتخلص من مشكلة تذيل صفحات اوراق العمل - سعيد بيرم.rar

[أبو سجده]

اخى العزيز الفاضل الحاج // احمد يعقوب

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

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

فكرتان أروع من بعضهما وإن كنت أميل لحل

الاستاذ الفاضل أخى // شوقى ربيع بارك الله فيه وفى سيادتكم

تقبل وافر احترامى وتقديرى ... وجزاكم الله خيرا

[أبو سجده]

اخى العزيز الفاضل الاستاذ // شوقى ربيع

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

تمام الله ينور على حضرتك 

هل يمكن تعديل الكود لينسخ ارتفاع الصفوف اى كان ارتفاعها حال تغيره هذه واحده

اما الاخرى رجاء وفضلا أن تجعل عمليه نسخ محتوى التذيل بنفس الارتفاع حسب تغيره

لاحظ اخى الحبيب مع تغيير ارتفاع الصفوف الى مثلا الى 55 عند نسخها تصبح 40

لحين توافرالوقت لدى سيادتكم للنظرفى أخر جزئية ألا وهى فواصل الصفحات نظرا لأهميتها

تقبل وافر احترامى وتقديرى

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

تم تعديل أغسطس 27, 2014 بواسطه سعيد بيرم

[أبو سجده]

للرفع

[علي المصري]

السلام عليكم

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

اما الحل هو فقط اضغط  على  F2 وشاهد بنفسك

تحياتي

 

بالنسبة لعدم تغيير تسمية االصفحات

الكود الذي استخدمته حضرتك كالتالي

Sub Copeir_Data()
Dim sh As Worksheet: Set sh = Sheets("data")
Dim sh2 As Worksheet: Set sh2 = Sheets("مكافاة الثانوية العامة")
Dim lr As Long: lr = sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Row + 2
    sh.Range("A1:AD5").Copy
    sh2.Range("A" & lr).Select: ActiveSheet.Paste
End Sub

Sub Copeir_Tebel()
Dim sh As Worksheet: Set sh = Sheets("data")
Dim sh2 As Worksheet: Set sh2 = Sheets("مكافاة الثانوية العامة")
Dim lr As Long: lr = sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Row + 2
    sh2.Range("A8:AD28").Copy
    If sh2.Range("B" & lr) <> "" Then
        sh2.Range("A" & lr + 5).Select
        ActiveSheet.Paste
        Else
        MsgBox " ليس هناك تذيل لصفحة السابقة لايمكنك نسخ الجدول"
    End If
End Sub

Sub main()
Dim MSG, MSG2: MSG = MsgBox("هل تريد نسخ محتوى التذيل المطلوب", vbYesNo)
    If MSG = vbYes Then
    Call Copeir_Data
    MSG2 = MsgBox("هل تريد نسخ الصفوف من 8 الى 28", vbYesNo)
    If MSG2 = vbYes Then
    Call Copeir_Tebel
    Else: End
    End If
    Else: End
    End If
End Sub

يمكنك التعديل عليه بالطريقة التالية

بدلا من كتابة اسم الصفحة الظاهر في تبويب الصفحة نكتب اسم الصفحة الموجود في vba لها

مثلا الصفحة Data يقابلها  Feuil1   ( بالفرنسية على ما اظن )  أو  (  sheet1  )  باللغة الانجليزية

 

وعلى ذلك يكون الكود بالشكل التالي

جرب ووغير اسم الصفحة وشوف النتيجة

Sub Copeir_Data()
Dim sh As Worksheet: Set sh = Feuil1
Dim sh2 As Worksheet: Set sh2 = Feuil2
Dim lr As Long: lr = sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Row + 2
    sh.Range("A1:AD5").Copy
    sh2.Range("A" & lr).Select: ActiveSheet.Paste
End Sub

Sub Copeir_Tebel()
Dim sh As Worksheet: Set sh = Feuil1
Dim sh2 As Worksheet: Set sh2 = Feuil2
Dim lr As Long: lr = sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Row + 2
    sh2.Range("A8:AD28").Copy
    If sh2.Range("B" & lr) <> "" Then
        sh2.Range("A" & lr + 5).Select
        ActiveSheet.Paste
        Else
        MsgBox " ليس هناك تذيل لصفحة السابقة لايمكنك نسخ الجدول"
    End If
End Sub

Sub main()
Dim MSG, MSG2: MSG = MsgBox("هل تريد نسخ محتوى التذيل المطلوب", vbYesNo)
    If MSG = vbYes Then
    Call Copeir_Data
    MSG2 = MsgBox("هل تريد نسخ الصفوف من 8 الى 28", vbYesNo)
    If MSG2 = vbYes Then
    Call Copeir_Tebel
    Else: End
    End If
    Else: End
    End If
End Sub

شكرا

[عبدالله المجرب]

 

هل يمكن تعديل الكود لينسخ ارتفاع الصفوف اى كان ارتفاعها حال تغيره هذه واحده

اما الاخرى رجاء وفضلا أن تجعل عمليه نسخ محتوى التذيل بنفس الارتفاع حسب تغيره

لاحظ اخى الحبيب مع تغيير ارتفاع الصفوف الى مثلا الى 55 عند نسخها تصبح 40

 

 

السلام عليكم 

لعمل ذلك ضف هذها السطر على الكود Copeir_Data

 Selection.RowHeight = sh.Range("A1").RowHeight

ليصبح 

Sub Copeir_Data()
Dim sh As Worksheet: Set sh = Sheets("data")
Dim sh2 As Worksheet: Set sh2 = Sheets("مكافاة الثانوية العامة")
Dim lr As Long: lr = sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Row + 2
    sh.Range("A1:AD5").Copy
    sh2.Range("A" & lr).Select: ActiveSheet.Paste
    Selection.RowHeight = sh.Range("A1").RowHeight
End Sub

والله أعلم

[أبو سجده]

اخى العزيز الاستاذ الفاضل وحبيب قلبى // أبو أحمد

بشأن إضافتكم فهى إضافه أكثرمن رائعه وقد أتت بثمارها 100%

وأطمع فى إضافة أخرى ألا وهى الترقيم التلقائى

بداية من الكشف الثانى اعتمادا على نهاية الرقم المدون بالكشف الاول

ويبقى السؤال وهو المهم فى الموضوع

هل من إضافة كود لتثبيت فواصل الصفحات عند عدد معين من الصفوف

أى كل 33 صف بداية من الصف 1 وحتى 33

 نرجو الافاده

جزاكم الله خيرا وبارك فيكم وفى أولادكم

تم تعديل سبتمبر 1, 2014 بواسطه سعيد بيرم

[شوقي ربيع]

اخى العزيز الفاضل الاستاذ // شوقى ربيع

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

تمام الله ينور على حضرتك 

هل يمكن تعديل الكود لينسخ ارتفاع الصفوف اى كان ارتفاعها حال تغيره هذه واحده

اما الاخرى رجاء وفضلا أن تجعل عمليه نسخ محتوى التذيل بنفس الارتفاع حسب تغيره

لاحظ اخى الحبيب مع تغيير ارتفاع الصفوف الى مثلا الى 55 عند نسخها تصبح 40

لحين توافرالوقت لدى سيادتكم للنظرفى أخر جزئية ألا وهى فواصل الصفحات نظرا لأهميتها

تقبل وافر احترامى وتقديرى

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

 

السلام عليكم

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

اما بخصوص ما طلبت اضن ان هذا هو المطلوب

 

'####### RABIE CHAOUKI #########

Sub Copeir_Data() ' áäÓÎ ÇáÊÐíá ÈäÝÓ ÚÑÖ ÇáÕÝæÝ Ýí ÕÝÍÉ ÇáÏÇÊÇ ÍÊì Çä ÛíÑÊ ÇáÇÑÊÝÇÚ
Dim sh As Worksheet: Set sh = Sheets("data")
Dim sh2 As Worksheet: Set sh2 = Sheets("ãßÇÝÇÉ ÇáËÇäæíÉ ÇáÚÇãÉ")
Dim lr As Long: lr = sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Row + 2
    sh.Rows("1:5").Copy
    sh2.Range("A" & lr).Select: ActiveSheet.Paste
End Sub

Sub Copeir_Tebel() 'áäÓÎ ÇáÌÏæá ÇíÖÇ ÈäÝÓ ÇÑÊÝÇÚ ÇáÕÝæÝ
Dim sh As Worksheet: Set sh = Sheets("data")
Dim sh2 As Worksheet: Set sh2 = Sheets("ãßÇÝÇÉ ÇáËÇäæíÉ ÇáÚÇãÉ")
Dim lr As Long: lr = sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Row + 2
      sh2.Rows("8:28").Copy
      sh2.Range("A" & lr + 5).Select
      ActiveSheet.Paste
      lr = sh2.Cells(sh2.Rows.Count, 2).End(xlUp).Row
      ActiveSheet.PageSetup.PrintArea = "$A$1:$AD" & lr
Dim Str As Byte: Str = 34
Dim i As Integer
    FinalRow = Range("A65536").End(xlUp).Row
    For i = Str To lr Step 26
    ActiveSheet.HPageBreaks.Add before:=Cells(i, 1)
    Next i
End Sub

Sub main() ' áÇÓÊÏÚÇÁ ÇæÇãÑ äÓÎ ÇáÊÐíá æÇáÌÏæá
Dim MSG, MSG2: MSG = MsgBox("åá ÊÑíÏ äÓÎ ãÍÊæì ÇáÊÐíá ÇáãØáæÈ", vbYesNo)
    If MSG = vbYes Then
    Call Copeir_Data
    MSG2 = MsgBox("åá ÊÑíÏ äÓÎ ÇáÕÝæÝ ãä 8 Çáì 28", vbYesNo)
    If MSG2 = vbYes Then
    Call Copeir_Tebel
    Else: End
    End If
    Else: End
    End If
End Sub

 

فكرة جديده للتخلص من مشكلة تذيل صفحات اوراق العمل - سعيد بيرم.rar

[أبو سجده]

أخى العزيز الفاضل الاستاذ // شوقى ربيع

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

ربنا يبارك فى عمرحضرتك

ليس هناك مايدعو للإعتذار

أعانكم الله تعالى على مسؤلياتكم

تم تحميل المرفق

برجاء متابعة المشاركة رقم 16

بشأن الترقيم وكذا امكانية اضافة

كود لتثبيت فواصل الصفحات عند عدد معين من الصفوف

نظرا لاهمية هذه الجزئية وهى الاهم فى هذا الموضوع

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

وإخوانى الاعزاء الافاضل 

الحاج // أحمد يعقوب

والاستاذ // عبدالله المجرب

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

[أبو سجده]

ياصالح الحال يالله

تم تعديل سبتمبر 1, 2014 بواسطه سعيد بيرم

[أبو سجده]

الله ينورعليك ياأبوربيع

بهذا التعديل الجوهرى قد تم التغلب على

مشكلة فواصل الصفحات

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

تم تعديل سبتمبر 2, 2014 بواسطه سعيد بيرم

[شوقي ربيع]

وهذا الحل بخصوص الترقيم

تحياتي لك

 

فكرة جديده للتخلص من مشكلة تذيل صفحات اوراق العمل - سعيد بيرم.rar

[أبو سجده]

الكمال لله وحده

تم وبحمد الله

وبفضل الله وبفضلكم

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

جارى رفع الموضوع بموضوع منفصل 

لعموم الفائدة مع ضرورة تثبيت

الموضوع لاهميته

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

تم تعديل سبتمبر 2, 2014 بواسطه سعيد بيرم

[أبو سجده]

الاستاذ الفاضل // شوقى ربيع 

السلام عليكم

بعد إذن سيادتكم

مع اضافة الاعمدة المظلله باللون الرمادى

حدث خلل فى الترقيم التلقائى

حيث انتهى الكشف الثانى برقم 20 

والمفترض ان ينتهى برقم 40

لذا يرجى عمل اللازم

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

فكرة جديده للتخلص من مشكلة تذيل صفحات اوراق العمل - سعيد بيرم.rar

[أبو سجده]

للرفع

[أبو سجده]

للرفع