اضافةصف فارغ تحت كل سطر

[ابوصلاح]

اريد ادرج صف فارغ تحت كل صف به بيانات

والصف الذي ليس به بيانات يتوقف الكود عنده

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

أخي الكريم أبو صلاح

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

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

نفس فكرة الكود موجودة في الموضوع على الرابط التالي (مع تعديلات بسيطة جداً ليناسب طلبك)

الرابط من هنا

[ابوصلاح]

في هذا الكود (هو كود رائع) لكنه لا يضيف سطر فارغ تحت اخر صف به بيانات

وهذا المرفق

اضافة وحذف الصفوف.rar

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

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

Sub Add_Rows()
    Dim I As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
        With ActiveSheet
            I = ActiveSheet.UsedRange.Rows.Count
            For I = .Cells.SpecialCells(xlLastCell).Row To 6 Step -1
                If Len(Trim(Cells(I, 2))) <> 0 Then Rows(I).Insert
            Next I
            Rows(.Cells.SpecialCells(xlLastCell).Row).Copy
            Rows(.Cells.SpecialCells(xlLastCell).Row + 1).PasteSpecial Paste:=xlPasteFormats
        End With
    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Sub Delete_Rows()
    Dim I As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
        I = ActiveSheet.UsedRange.Rows.Count
        For I = Cells.SpecialCells(xlLastCell).Row To 6 Step -1
            If Len(Trim(Cells(I, 2))) = 0 Then Rows(I).Delete
        Next I
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

تقبل تحياتي

[ابوصلاح]

يا سلام استاذ ياسر دائما حاضر بالرد تسلم تسلم

بارك الله فيك وجعله الله في ميزان حسناتك

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

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

ومشكور على دعائك الطيب ، ولك بمثل إن شاء الله

تقبل تحياتي