Çözüldü Hücre İçindeki Sayının 1 Eksiği Kadar Boş Satır Eklemek

[likaba]

Merhabalar,

Ekli excelde ki tablonun "E" sütununda yer alan sayının 1 eksiği kadar hemen alta boş satır eklemek istiyorum. Nasıl yapmam konusunda yardımcı olabilir misiniz?


https://s6.dosya.tc/server12/xo6095/BosSatirOlusturmak.xlsx.html

 

[Necdet]

Merhaba,
Deneyiniz.

Public Sub deneme()

Dim i As Long

For i = Cells(Rows.Count, "A").End(3).Row To 2 Step -1
    Rows(i + 1 & ":" & i + 1 + Cells(i, "E") - 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next i

End Sub

 

[Muzaffer Ali]

Alternatif

Sub Test()
    Dim Bak As Long
    Dim SonSatir As Long
    Application.ScreenUpdating = False
    SonSatir = Cells(Rows.Count, "E").End(xlUp).Row
    If Cells(SonSatir, "E") > 1 Then
        Range("A" & SonSatir & ":E" & SonSatir).Copy
        Range("A" & SonSatir + 1 & ":E" & SonSatir + Cells(SonSatir, "E") - 1).PasteSpecial xlPasteFormats
    End If
    For Bak = SonSatir - 1 To 2 Step -1
        If Cells(Bak, "E") > 1 Then
            Range("A" & Bak + 1 & ":E" & Bak + Cells(Bak, "E") - 1).Insert Shift:=xlDown
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Tamamlandı"
End Sub

 

[likaba]

Merhaba,
Deneyiniz.

Public Sub deneme()

Dim i As Long

For i = Cells(Rows.Count, "A").End(3).Row To 2 Step -1
    Rows(i + 1 & ":" & i + 1 + Cells(i, "E") - 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next i

End Sub

çok teşekkür ederim Necdet Bey

 

[likaba]

Alternatif

Sub Test()
    Dim Bak As Long
    Dim SonSatir As Long
    Application.ScreenUpdating = False
    SonSatir = Cells(Rows.Count, "E").End(xlUp).Row
    If Cells(SonSatir, "E") > 1 Then
        Range("A" & SonSatir & ":E" & SonSatir).Copy
        Range("A" & SonSatir + 1 & ":E" & SonSatir + Cells(SonSatir, "E") - 1).PasteSpecial xlPasteFormats
    End If
    For Bak = SonSatir - 1 To 2 Step -1
        If Cells(Bak, "E") > 1 Then
            Range("A" & Bak + 1 & ":E" & Bak + Cells(Bak, "E") - 1).Insert Shift:=xlDown
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Tamamlandı"
End Sub

çok teşekkür ederim Muzaffer Ali bey

 

[Muzaffer Ali]

Rica ederim. Kolay gelsin.