ادراج صفوف فارغة

[hitech]

اريد ادراج صفوف فارغة كما هو مرفق بالملف

 

 

ادراج صفوف.xlsm

[Ali Mohamed Ali]

تفضل لك ما طلبت

Sub t()
Dim i, itotalrows As Integer
Dim strRange As Range, strRange2 As Range
Dim col As Long

itotalrows = ActiveSheet.Range("a65536").End(xlUp).Offset(1, 0).Row

For col = 1 To 1
Do While i <= itotalrows
    i = i + 1
    Set strRange = Cells(i, col)
    Set strRange2 = Cells(i + 1, col)
    If strRange.Text <> strRange2.Text Then
        Rows(i + 1).EntireRow.Insert
            itotalrows = ActiveSheet.Range("a65536").End(xlUp).Offset(1, 0).Row
        i = i + 1
    End If
Loop
Next col
End Sub

وهذا كود اخر اصغر

Sub InsertBlankRows()

Dim LastRow As Long
Dim i As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

For i = LastRow To 2 Step -1
    If i = 1 Then
        'Do nothing
    ElseIf Cells(i, "A") <> Cells(i - 1, "A") Then
        Cells(i, "A").Insert
    End If
Next i

End Sub

ادراج 1صفوف.xlsm

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

بعذ اذن الاخ علي وزيادة في اثراء الموضوع

هذا الكود

Option Explicit

Sub Insert_rows()
Dim lra%, i%, k%
Dim dic As Object, Itm
lra = Cells(Rows.Count, 1).End(3).Row
On Error Resume Next
Range("A1:A" & lra).SpecialCells(xlCellTypeBlanks). _
EntireRow.Delete
On Error GoTo 0
lra = Cells(Rows.Count, 1).End(3).Row
Set dic = CreateObject("Scripting.dictionary")
For i = 1 To lra
  dic(Range("A" & i).Value) = _
  Range("A" & i).Row
Next
For Each Itm In dic.items
    Rows(Itm + 1 + k).Insert
    k = k + 1
 Next
End Sub

الملف مرفق

Insert_Ro.xlsm

[hitech]

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