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

**أبو سجده** · أغسطس 25, 2014

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

وبه نستعين

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

ثم نعم

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

ثم نعم

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

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

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

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

**اسلام سيد** · أغسطس 25, 2014

السلام عليكم

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

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

**احمدزمان** · أغسطس 26, 2014

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

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

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

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

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

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

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

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

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

**أبو سجده** · أغسطس 26, 2014

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

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

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

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

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

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

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

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

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

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

**أبو سجده** · أغسطس 26, 2014

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

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

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

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

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

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

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

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

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

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

**شوقي ربيع** · أغسطس 26, 2014

السلام عليكم

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

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

تحياتي

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

**احمدزمان** · أغسطس 26, 2014

السلام عليكم

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

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

تحياتي

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

**أبو سجده** · أغسطس 26, 2014

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

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

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

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

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

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

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

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

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

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

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

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

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

**احمدزمان** · أغسطس 26, 2014

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

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

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

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

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

**شوقي ربيع** · أغسطس 26, 2014

السلام عليكم

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

**أبو سجده** · أغسطس 27, 2014

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

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

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

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

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

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

**أبو سجده** · أغسطس 27, 2014

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

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

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

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

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

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

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

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

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

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

**أبو سجده** · أغسطس 29, 2014

للرفع

**علي المصري** · أغسطس 29, 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

شكرا

**عبدالله المجرب** · أغسطس 31, 2014

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

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

لاحظ اخى الحبيب مع تغيير ارتفاع الصفوف الى مثلا الى 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

والله أعلم

**أبو سجده** · سبتمبر 1, 2014

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

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

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

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

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

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

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

نرجو الافاده

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

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

**شوقي ربيع** · سبتمبر 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

**أبو سجده** · سبتمبر 1, 2014

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

**أبو سجده** · سبتمبر 1, 2014

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

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

**أبو سجده** · سبتمبر 1, 2014

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

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

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

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

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

**شوقي ربيع** · سبتمبر 1, 2014

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

تحياتي لك

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

**أبو سجده** · سبتمبر 2, 2014

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

تم وبحمد الله

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

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

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

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

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

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

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

**أبو سجده** · سبتمبر 5, 2014

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

السلام عليكم

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

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

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

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

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

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

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

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

**أبو سجده** · سبتمبر 7, 2014

للرفع

**أبو سجده** · سبتمبر 8, 2014

للرفع

تسجيل الدخول

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

الردود الموصى بها

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

شوقي ربيع

شوقي ربيع

احمدزمان

انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد

انشئ حساب جديد

تسجيل دخول

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information