her döngüde belli sayıda satır silme

[Gold_Savt]

Elimde bin defa tekrarlanması gereken bir liste var. (Bazen liste binden aşağı olabiliyor)
Listenin ilk 13 satırını silmem gerekiyor. 14,15 ve 16 satırlar kalacak.
Sonra döngü tekrar başlayacak. sıradaki 13 satır silip kalan üç satırı bırakacak şekilde bin defa tekrar etmesi lazım. Kendi formüllerim işe yaramıyor.
iki satırda bir satır silme gibi formülleri çeviremedim. Bilen arkadaşlarının yardımlarını bekliyorum.

 

[Cengiz Demir]

Bu kodu deneyin

Sub sil()
Dim i
Dim k

i = 1

dongu:

    k = Cells(i, 1): If k = "" Then Exit Sub

    Range(Cells(i, 1), Cells(i + 12, 1)).EntireRow.Delete

    i = i + 3

GoTo dongu:

End Sub

 

[veyselemre]

Sub test()
    Dim son&, sut&, i&, say&, liste
    Application.ScreenUpdating = False
    sut = 2
    For i = sut To Columns.Count
        If WorksheetFunction.CountBlank(Columns(i)) = Rows.Count Then
            sut = i
            Exit For
        End If
    Next i
    say = -2
    son = Cells(Rows.Count, 1).End(3).Row
    ReDim liste(1 To son, 1 To 1)
    For i = 1 To son Step 16
        say = say + 3
        liste(i + 13, 1) = say
        liste(i + 14, 1) = say + 1
        liste(i + 15, 1) = say + 2
    Next i
    Cells(1, sut).Resize(son).Value = liste
    Range("A1").Resize(son, sut).Sort Key1:=Cells(1, sut), Header:=xlNo

    Rows(say + 3 & ":" & son).Delete
    Columns(sut).ClearContents

    Application.ScreenUpdating = True

    MsgBox "İşlem tamam", vbInformation
End Sub

 

[Gold_Savt]

Cengiz Demir Bey, teşekkür ederim. Sağlıklı bir döngü gerçekleşiyor. Bunu kullanacağım.
Veysel Emre Bey, teşekküre derim. Sizinkinde sadece A sütununda sağlıklı bir döngü gerçekleşiyor. Aslında çok hızlı tamamlıyor ama diğer sütunlarda karışma söz konusu oluyor. A sütunu hariç diğer sütunlar birbirine giriyor. Ya da sadece bende böyle oluyor.
Elinize emeğinize sağlık.

 

[veyselemre]

Veysel Emre Bey, teşekküre derim. Sizinkinde sadece A sütununda sağlıklı bir döngü gerçekleşiyor. Aslında çok hızlı tamamlıyor ama diğer sütunlarda karışma söz konusu oluyor. A sütunu hariç diğer sütunlar birbirine giriyor. Ya da sadece bende böyle oluyor.
Elinize emeğinize sağlık.

Kod örneğinize göre hazırlandı. Örnek dosyanız gerçek dosyanızla aynı yapıda olsaydı sorun çıkmazdı.

Sub test()
    Dim son&, sut&, i&, say&, liste
    Application.ScreenUpdating = False
    sut = 2
    For i = 100 To sut Step -1
        If WorksheetFunction.CountBlank(Columns(i)) <> Rows.Count Then
            sut = i + 1
            Exit For
        End If
    Next i
    say = -2
    son = Cells(Rows.Count, 1).End(3).Row
    ReDim liste(1 To son, 1 To 1)
    For i = 1 To son Step 16
        say = say + 3
        liste(i + 13, 1) = say
        liste(i + 14, 1) = say + 1
        liste(i + 15, 1) = say + 2
    Next i
    Cells(1, sut).Resize(son).Value = liste
    Range("A1").Resize(son, sut).Sort Key1:=Cells(1, sut), Header:=xlNo

    Rows(say + 3 & ":" & son).Delete
    Columns(sut).ClearContents

    Application.ScreenUpdating = True

    MsgBox "İşlem tamam", vbInformation
End Sub