Satır ekleme sorunu

[polis-53]

Arkadaşlar Elimde uzunca bir listem var bu listemde her 17 satırda bir 4 satır eklemek istiyorum fakat ekte göndermiş olduğum dosyadada anlaşılacağı gibi bir yere kadar satır ekliyor ondan sonra eklemiyor bu sorunu çözemedin yardımlarınızı bekliyorum

 

[hamitcan]

Aşağıdaki şekilde deneyin.

Sub satirac()
    For i = 1 To [a65536].End(3).Row
        c = c + 1
        If c = 17 Then
            Rows(i + 1 & ":" & i + 3).Insert
            c = 0
            i = i + 3
        End If
    Next
End Sub

 

[polis-53]

yine aynı hatayı veriyor

 

[Necdet]

Merhaba,

TOPLAM satırından sonra mı 4 satır eklenecek?

 

[hamitcan]

yine aynı hatayı veriyor

Hata nedir ?

 

[polis-53]

evet toplam satırından sonra satır ekleyecek fakat bir yerekadar ekliyor ondan sonra eklemiyor

 

[Ömer]

Merhaba,

Aynı konuyla ilgili birden fazla başlık açmamanızı rica ederim. Eğer cevap sizin için yetersiz ise aynı konunun devamına durumu bildiren mesaj yazabilirsiniz.

http://www.excel.web.tr/showthread.php?t=81819

Bu şekilde deneyin.

Sub SatirEkle()
Application.ScreenUpdating = False
Dim i, son, say As Long
say = Application.CountIf([A:A], "KURUM NO")
son = [A65536].End(3).Row + say * 4
    For i = 17 To son Step 20
        Rows(i & ":" & i + 3).Insert Shift:=xlDown
    Next i
Application.ScreenUpdating = True
End Sub

.

 

[hamitcan]

i = i + 4 satırını

i = i + 3 şeklinde değiştirince oldu.

 

[Necdet]

Merhaba,

Alternatif Olsun.

Sub SatirEkle()
Dim c As Range
Dim i As Long
Dim Adet As Integer
Dim Adres As String
Adet = 4
Application.ScreenUpdating = False
With Worksheets(1).Range("a:a")
    Set c = .Find("TOPLAM", LookIn:=xlValues, LookAt:=xlWhole)
    If Not c Is Nothing Then
        Adres = c.Address
        Do
            Rows(c.Row + 1 & ":" & c.Row + Adet).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adres
    Else
        Exit Sub
    End If
End With
Application.ScreenUpdating = True
MsgBox "İşlem tamamlanmıştır..."
End Sub

 

[polis-53]

çok teşekkur ederim şimdi oldu sağolun var olun