حسين بلال

تم الحل والحمد لله. أورد الحل للإفادة. جزاكم الله خيراً
 
 
الحل الأول: ( الأسرع والأفضل بنظري )
Sub hbsqn() Dim i As Long Dim x As Integer Application.ScreenUpdating = False For i = Range("A" & Rows.count).End(3)(1).Row To 2 Step -1 If Range("A" & i).Value = Range("A" & i - 1).Value Then Range("A" & i - 1).EntireRow.Delete End If Next i x = 9 Do Until x = 0 Range("A" & Rows.count).End(3)(0).Select Do Until ActiveCell.Row = 1 If ActiveCell.Value + 1 <> ActiveCell.Offset(1).Value Then ActiveCell.Offset(1).EntireRow.Insert ActiveCell.Offset(1).Value = ActiveCell.Value + 1 ActiveCell.Offset(1, 1).Value = 33 ActiveCell.Offset(1, 2).Value = "" ActiveCell.Offset(1, 3).Value = ActiveCell.Offset(, 3).Value End If ActiveCell.Offset(-1).Select Loop x = x - 1 Loop Application.ScreenUpdating = True End Sub الحل الثاني:
Sub FormatClosingBalance() Dim rng As Range Dim i As Long Set rng = Selection rng.Copy rng.PasteSpecial xlPasteValues For i = rng.Rows.Count To 2 Step -1 Select Case rng(i - 1, 1) Case rng(i, 1) Rows(i - 1).Delete Case Is = rng(i, 1) - 1 'Do nothing here Case Is < rng(i, 1) - 1 Rows(i).Insert Cells(i, 1).Value = rng(i + 1, 1) - 1 Cells(i, 2).Value = 33 Cells(i, 4).Value = rng(i - 1, 4) i = i + 1 Case Else 'Headers dont match row 2 End Select Next i rng.Columns(3).Delete 'Delete this if you don't need to delete the Amount Column End Sub