لصق دباجة اسفل كل شيت

[سالم سالم]

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

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

هذا الملف يحتوى على عدد 300 طالبة ( وهو عدد متغير ) وبه كود يقوم بنسخ الدباجة الموجودة فى الصفوف 27 : 29 ( وهى صفوف ثابتة ) ويلصقها اسفل كل 20 طالبة والمشكلة ان الكود يطلب كل مرة رقم الصف الذى يتم اللصق فيه وكنت الصق من اسفل إلى أعلى لتفادى الازاحة ويعمل الكود بطريقة طبيعية ويؤدى الغرض

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

بارك الله فيكم ناجح 1.xlsm

[سليم حاصبيا]

    حرب هذا الكود (  DIBAJA  هي النطاق الذي يحتوي على الديباجة من B1  الى AZ4 )

كان الأفضل عدم ادراج علة العلل بالنسبة للأكواد والمعادلات وهي الخلايا المدمجة

صفحة salim من هذا الملف

Sub salim_rows()
Dim t%, lr%, x%, z%, a%
Dim my_rg As Range, k%
Dim In_box
If ActiveSheet.Name <> "Salim" Then GoTo End_Me
Application.ScreenUpdating = False
del_Empty_rows
In_box = Application.InputBox("How Many Rows", , 20)
a = In_box - 1 'number of rows for every group
z = 3 'number of rows to be insert every time
x = 7 'first row to begine
If a <= 0 Then Exit Sub
t = x + a + 1
If z > 5 Then z = 5

lr = Cells(Rows.Count, 2).End(3).Row
On Error Resume Next
Set my_rg = Range("B" & x & ":B" & lr).SpecialCells(4)
my_rg.EntireRow.Delete
On Error GoTo 0
    Do Until Cells(t, "B") = ""

        Rows(t).Resize(z).Insert
        Range("DIBAJA").Copy _
        Cells(t, 1)
        t = t + a + z + 1
       
    Loop
End_Me:

Application.ScreenUpdating = True
End Sub
'++++++++++++++++++++++++++++
Sub del_Empty_rows()
On Error Resume Next
Dim lr%: lr = Cells(Rows.Count, 2).End(3).Row
 Range("Ba7:Ba" & lr).SpecialCells(4).EntireRow.Delete
 On Error GoTo 0
End Sub

الملف مرفق

 

 

 

Najehoun.xlsm

[سالم سالم]

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

الاستاذ الفاضل / سليم شكرا على مرورك الكريم

لى تعليقان

الاول

الدباجة المراد تكرارها هى الصفوف 27 ، 28 ، 29

الثانى

اللصق يكون كل 20 طالب بعنى تحت الطالب رقم 20 ، 40 ،60 ،، وهكذا

[سليم حاصبيا]

بالنسبة للصق (يمكنك الاختيار من خلال الـــ  Input Box عدد الصفوف في كل مرة والافتراضي هو 20 لذلك اذا اردت اكثر  أو اقل حدد بنفسك واضغط Ok)

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

  الملف الجديد مرفق (بردو الصفحة  Salim من هذا الملف لأني لا اريد ان أغير شيئاً بالشيت الأولى حفاظاَ على محتوياتها)

الزر Del Dibaja   هو لارجاع البيانات الأصلية كما كانت  بدون ديباجات

الماكرو الجديد

Sub salim_rows()
Dim t%, lr%, x%, z%, a%
Dim my_rg As Range, k%
Dim In_box
If ActiveSheet.Name <> "Salim" Then GoTo End_Me
Application.ScreenUpdating = False
del_Empty_rows
In_box = Application.InputBox("How Many Rows", , 20)
a = In_box - 1 'number of rows for every group
z = 3 'number of rows to be insert every time
x = 7 'first row to begine
If a <= 0 Then Exit Sub
t = x + a + 1
If z > 5 Then z = 5

lr = Cells(Rows.Count, 2).End(3).Row
On Error Resume Next
Set my_rg = Range("B" & x & ":B" & lr).SpecialCells(4)
my_rg.EntireRow.Delete
On Error GoTo 0
    Do Until Cells(t, "B") = ""

        Rows(t).Resize(z).Insert
        Sheets("sheet1").Range("My_DEB").Copy _
        Cells(t, 1)
        t = t + a + z + 1
       
    Loop
End_Me:

Application.ScreenUpdating = True
End Sub
'++++++++++++++++++++++++++++
Sub del_Empty_rows()
On Error Resume Next
Dim lr%: lr = Cells(Rows.Count, 2).End(3).Row
 Range("Ba7:Ba" & lr).SpecialCells(4).EntireRow.Delete
 On Error GoTo 0
End Sub

الملف من جديد

 

Najehoun.xlsm_1.xlsm

[سالم سالم]

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

الاستاذ الموقر/ سليم

بارك الله فيك الملف الأخير تمام

وكنت اطمع ان يكون العمل على صفحة العمل ( شيت تبيض الدور الأول ) فقط دون إضافة أى صفحات أخرى - Salim ، Sheet1 -

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

 

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

[سليم حاصبيا]

تم معالجة الأمر

الشيت "شيت تبيض الدور الأول" يمكن اخفائها اذا اردت أم يمكن حذفها نهائياً لكن Sheet1 لا يمكن الاستغناء عنها لأنها تحتفظ بالديباجة

اذا زاد او نقص عدد الطلاب يمكن ازالة الديباجات بواسطة الماكرو المخصص لهذه الغاية (الزر Del Dibaja ) تم التعديل على البيانات (دون صفوف فارغة) و من ثم تقسيم الديباجات على الصفحة حسب الرقم الذي تريده من الــ  Input Box

الكود الجديد

Sub salim_rows()
Dim t%, lr%, x%, z%, a%
Dim my_rg As Range, k%
Dim In_box, ro%
If ActiveSheet.Name <> "Salim" Then GoTo End_Me
Application.ScreenUpdating = False
del_Empty_rows
In_box = Application.InputBox("How Many Rows", , 20)
a = In_box - 1 'number of rows for every group
z = 3 'number of rows to be insert every time
x = 7 'first row to begine
If a <= 0 Then Exit Sub
t = x + a + 1
If z > 5 Then z = 5

lr = Cells(Rows.Count, 2).End(3).Row
On Error Resume Next

On Error GoTo 0
    Do Until Cells(t, "B") = ""

        Rows(t).Resize(z).Insert
        Sheets("sheet1").Range("My_DEB").Copy _
        Cells(t, 1)
        t = t + a + z + 1
       
    Loop
    ro = ActiveSheet.Cells(Rows.Count, 2).End(3).Row
    Rows(ro + 1).Resize(z).Insert
        Sheets("sheet1").Range("My_DEB").Copy _
        Cells(ro + 1, 1)
End_Me:

Application.ScreenUpdating = True
End Sub
'++++++++++++++++++++++++++++
Sub del_Empty_rows()
On Error Resume Next
Dim lr%: lr = Cells(Rows.Count, 2).End(3).Row
Range("B" & lr + 1).Resize(20).EntireRow.Delete
 Range("Ba7:Ba" & lr).SpecialCells(4).EntireRow.Delete
 On Error GoTo 0
End Sub

الملف من جديد

 

Najehoun.xlsm_2.xlsm

[سالم سالم]

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

الاستاذ/ سليم

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