ازاحة صفوف بعدد معين

[احمد 505]

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

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

وكل عام وانتم طيبين

وتقبل الله منا ومنكم صالح الاعمال

 

أساتذتي الكرام

1- يوجد لدي عدد كبير من الاسئلة في ورقة اكسل ( كل سؤال مكون من 6 صفوف ( صف للسؤال + 4 صفوف اجابة + صف فارغ بين كل سؤال والاخر )

 

2- والاجابات في ورقة اكسل اخرى ( كل اجابة في صف )

 

واريد ان اضع كل اجابة مقابل كل سؤال

 

المطلوب

 

اريد طريقة تجعل بين كل صف من صفوف الاجابات عدد 5 صفوف فارغة

لكي اتمكن من نسخ الاجابات والصاقها بسهوله امام كل الاسئلة

 

اتمنى يكون المطلوب واضح

 

اشكركم

ازاحة صفوف.rar

[طارق محمود]

السلام عليكم

أخي العزيز

أنظر الفيديو المرفق

Fill_Down.rar

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

جرب هذا الملف و( اضغط افضل اجابة اذا كان كذلك)

ازاحة صفوف salim.zip

[ياسر خليل أبو البراء]

أخي الكريم أحمد

بعد إذن أساتذتي إليك الحل التالي به شرح للكود لتعرف كيف تعدل عليه بما يناسب ملفك الأصلي

Sub FinalResult()
'يقوم الكود بتجميع البيانات من ورقتي العمل اسئلة واجابة
'لتظهر النتائج النهائية بها [Final] قم بإنشاء ورقة عمل باسم
'----------------------------------------------------------
'الإعلان عن المتغيرات
    Dim shQ As Worksheet, shAns As Worksheet
    Dim I As Long, X As Long
'تعيين أوراق العمل التي بها البيانات المراد التعامل معها
    Set shQ = Sheets("اسئلة"): Set shAns = Sheets("اجابة")
'تعيين المتغير ليساوي واحد وهو رقم أول صف في ورقة النتائج
    X = 1
'مسح بيانات الأعمدة من الأول للخامس في ورقة النتائج
    Sheets("Final").Columns("A:E").ClearContents

'بدء التعامل مع ورقة الأسئلة
    With shQ
'نسخ النطاق في العمود الخامس إلى آخر خلية بها بيانات
        .Range("E2:E" & .Cells(Rows.Count, "E").End(xlUp).Row).Copy
'لصق البيانات في ورقة النتائج في أول خلية بالعمود الخامس
        Sheets("Final").Range("E1").PasteSpecial xlPasteValues
    End With
   
'بدء التعامل مع ورقة اجابة
    With shAns
'حلقة تكرارية تمثل صفوف الورقة من الصف الثاني إلى آخر صف به بيانات
        For I = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
'النطاق في ورقة النتائج في الصف الأول يساوي النطاق في ورقة اجابة بامتداد ثلاثة أعمدة
            Sheets("Final").Range("A" & X).Resize(1, 3).Value = .Cells(I, 1).Resize(1, 3).Value
'زيادة المتغير بمقدار 6 للانتقال إلى الصف المناسب للبيانات التالية
            X = X + 6
        Next I
    End With
'إلغاء خاصية القص والنسخ
    Application.CutCopyMode = False
End Sub

قم بإنشاء ورقة عمل باسم Final

 

أرجو أن يكون المطلوب

Insert Rows.rar

[احمد 505]

اشكرك استاذي الكريم

طارق محمود

والطريقة ممتازة جداً وهي المطلوب

 

 

واشكر الاستاذ

سليم حصبيا

والطريقة ايضاً ممتازة

 

اشكركم جميعاً

وبارك الله فيكم

[احمد 505]

الاستاذ

ياسر خليل ابو البراء

اشكرك على المرفق

والطريق جداً سهله وسلسة

وهو فعلاً الملف المناسب لي

وقد قمت باستخدامه 

وادا الغرض حسب ما اريد

 

اشكرك استاذي الكريم

ونفعك الله بعلمك  

[ياسر خليل أبو البراء]

الحمد لله أخي الكريم أحمد أن تم المطلوب على خير

يرجى تحديد أفضل إجابة وليست مشاركتك أفضل إجابة (محدش هيزعل متخافش)

[احمد 505]

هههههههههههههههههههههه

المعذرة استاذي الكريم

والله ما انتبهت

اسف

واشكرك