نسخ صف محدد قبل كل الصفوف Copy Specific Row Before Each Row

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

إليكم كود يقوم بنسخ صف معين قبل كل الصفوف ، أي يقوم الكود بإدراج هذا الصف قبل كل الصفوف حسب الرغبة.

بفرض أن لديك ورقة عمل بها جدول بهذا الشكل :

والمطلوب أن يتم نسخ النطاق A1:D1 ويتم لصقه في كل الصفوف ، ليصبح بهذا الشكل :

يعتمد الكود على عمل حلقة تكرارية معكوسة أي أنها تبدأ من آخر صف بالنطاق في العمود الأول إلى الصف الثالث ، حيث يتم مع كل حلقة نسخ النطاق A1:D1 ، ثم إدراج النطاق المنسوخ قبل الصف الهدف.

وإليكم الكود المستخدم لتحقيق المطلوب ، يوضع الكود في موديول عادي Standard Module :

Sub Copy_Specific_Row()
    Dim I As Long
    
    Application.ScreenUpdating = False
        For I = Cells(Rows.Count, 1).End(xlUp).Row - 1 To 3 Step -1
            Range("A1:D1").Copy
            Range(Cells(I, "A"), Cells(I, "D")).Insert Shift:=xlDown
        Next I
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

تحميل الملف من هنا

إعداد / ياسر خليل أبو البراء