اذهب الي المحتوي
أوفيسنا

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


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

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

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

هذا الملف يحتوى على عدد 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

  • Like 2
  • Thanks 1
رابط هذا التعليق
شارك

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

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

لى تعليقان

الاول

الدباجة المراد تكرارها هى الصفوف 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

  • Like 2
  • Thanks 1
رابط هذا التعليق
شارك

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

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

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

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

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

 

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

  • Like 1
رابط هذا التعليق
شارك

  • أفضل إجابة

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

الشيت "شيت تبيض الدور الأول" يمكن اخفائها اذا اردت أم يمكن حذفها نهائياً لكن 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

  • Like 4
  • Thanks 1
رابط هذا التعليق
شارك

زائر
هذا الموضوع مغلق.
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information