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

[عبد الرحمن شفيق]

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


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

والشرح بالمثال بالمرفق ... ارجو حل موضوعي باقصي ما يمكنكم مع علمي بمشغولياتكم

في انتظار الرد

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

 

الفهرس .rar

[عبدالله باقشير]

السلام عليكم

 

جرب الكود التالي

Sub Macro1()
Dim Cont As Integer, Lr As Integer, R As Integer

Cont = Application.InputBox("إدخل عدد الصفوف", , 2, , , , , 1)
If Cont = 0 Then Exit Sub

Lr = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For R = Lr To 8 Step -1
    Rows(R).Resize(Cont).Insert Shift:=xlDown
Next
Application.ScreenUpdating = True
End Sub

تحياتي

[عبد الرحمن شفيق]

الاستاذ القدير / عبد الله باقشير

لا اعرف اشكرك باي طريقة

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

 

ولكن لي تعليق بسيط عليه انه يأخذ وقتا طويلا جدا

هل من الممكن ان امكن حل هذه المشكله وان لم يكن لها حل فالكود يفي بالغرض تماما

 

جزاك الله الف شكر

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

[عبدالله باقشير]

الاستاذ القدير / عبد الله باقشير

لا اعرف اشكرك باي طريقة

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

 

ولكن لي تعليق بسيط عليه انه يأخذ وقتا طويلا جدا

هل من الممكن ان امكن حل هذه المشكله وان لم يكن لها حل فالكود يفي بالغرض تماما

 

جزاك الله الف شكر

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

 

لقد قمت بتعديل الكود في المشاركة 2

جرب واشعرنا بالنتيجة

[عبد الرحمن شفيق]

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

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

[الحسامي]

السلام عليكم

مبدع اخي عبدالله كعادتك

ومن بعد اذنك هنا محاولة اخرى

Sub Macro1()
Application.ScreenUpdating = False
Dim Cont As Integer, rng As Range, R As Integer
On Error Resume Next
Cont = Application.InputBox("أدخل عدد الصفوف", , 2, , , , , 1)
If Cont = 0 Then Exit Sub
Set rng = Range([A7], [A65536].End(xlUp))
R = rng.Rows.Count
rng(1, 1).EntireColumn.Insert
Set rng = rng.Offset(0, -1)
rng(1, 1).Value = 1
rng(1, 1).AutoFill Destination:=rng, Type:=xlFillSeries

rng.Copy rng.Offset(R, 0).Resize(R * Cont, 1)
rng.Resize(R * (Cont + 1), 256).Sort Key1:=rng(1, 1), Order1:=xlAscending, Header:=xlNo
rng.EntireColumn.Delete

End Sub

[عبدالله باقشير]

السلام عليكم

 

نورت المنتدى اخي الحسامي

عسى المانع خيرا ...........حفظكم الله

 

تقبلوا تحياتي وشكري

[الحسامي]

المنتدى منور بك اخي خبور

لا حرمنا الله من علمك وخلق الطيب

وما منعا الا هموم الحياة واشغالها

بارك الله فيك وفي احبائك

[الـعيدروس]

السلام عليكم

 

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

والحل متشابه

قد كنا عملنا عليه

Sub ali_Insrt()
Dim i&, Str&, En&
Dim Lng%
With ActiveSheet
Application.ScreenUpdating = False
Str = 7: En = .Cells(.Rows.Count, 2).End(xlUp).Row
On Error Resume Next
Lng = InputBox("إدخل عدد الأسطر المراد إدراجها ", "")
If Lng = 0 Or Lng = cancel Or Lng = vbString Then Exit Sub
    For i = En To Str Step -1
        .Rows(i + 1).Resize(Lng).Insert
    Next i
On Error GoTo 0
Application.ScreenUpdating = True
End With
End Sub

[حمادة عمر]

يا لروعة هذا الموضوع وحظ صاحبه

من تواجد خيرة علماء الوطن العربي فيه

 

العلامة الخبير / عبد الله باقشير

القدير الكبير / عماد الحسامي

القدير الحبيب / عباد - ابونصار

 

فهنيئا لصاحب الموضوع

 

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

[عبد الرحمن شفيق]

بالفعل صدقت استاذي الحبيب الغالي / حمادة عمر - ابوسما

موضوع جميل بوجودكم انتم اساتذتي

فوالله احترت بين الاجابات فكلها راائعة

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

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

 

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