belirli aralıkta satır sildirme

[adnanyurdakul]

excel sayfasının ilk 16 kaydını sildikten sonra 61 satır aşağıya gidecek tekrar 16 kayıt silecek ve bu tüm sayfa boyunca sürecek ekteki örnekte bir şeyler yapmaya çalıştım ancak 1300 -1400 kayıt kadar siliyor döngü değerini yükselttiğim zaman "RANGE OF OBJECT global failed " hatası veriyor.(satır aralıkları örneği=
1:16,77:93,154:170,231:247,308:324,385:401,462:478,539:555,616:632,693:709,770:786,847:863,924:940,1001:1017,1078:1094,1155:1171,1232:1248,1309:1325,1386:1402,1463:1479)

Yardımcı olacak herkese teşekkürler.İyi Çalışmalar

 

[N.Ziya Hiçdurmaz]

yanıt

Verilen örnekte yazı boyutları silinmemesi gerekenlerin 6 kod 6 dan büyük olan satırları siler.

Sub sil()
Application.ScreenUpdating = False
    For sat = 1 To Cells(65536, "a").End(xlUp).Row
        If Cells(sat, "a").Font.Size <> 6 Then
            Cells(sat, "a").EntireRow.Delete shift:=xlUp
        End If
    Next
Application.ScreenUpdating = True
MsgBox "işlem tamam", vbInformation
End Sub

 

[adnanyurdakul]

Sayın N.Ziya Hiçdurmaz satır satır işlemlerde örneğiniz gayet güzel çalışıyor ancak ben dizi içinde işlem yapmak zorundayım. Farklı yol varsa onunlada yapılabilir ama 16 satır seç 61 satır sonra tekrar 16 satır seç61 satır sonra.. böyle giden bir yapıda nasıl olacak bilmiyorum. zaten 1500 civarındaki kayıt yazdığım kod ile çalışıyor.Sayfa sayısını artırdığımda hata veriyor kodlar aşağıdadır. İlgin için teşekkürler.

Sub adnan()
Dim baslik, artansatır As Integer
baslik = 16
artansatır = 61
Dim hepsi
Dim kasa As String
x = 1
Dim s() As String
ReDim s(0)

For i = 1 To 50 'sayfa sayısı kadar
If x = 1 Then
y = 16
asa = x & ":" & y
x = 2
GoTo adnan
Else
x = y + artansatır
y = x + baslik
asa = x & ":" & y
End If
adnan:
s(UBound(s)) = asa
ReDim Preserve s(UBound(s) + 1)
hepsi = Join(s, ",")
Next
hepsi = Left(hepsi, Len(hepsi) - 1)
Debug.Print Left(hepsi, Len(hepsi))
Rows(asa).Select
Range(hepsi).Select
Range("A" & x).Activate
Selection.Delete Shift:=xlUp
End Sub

 

[adnanyurdakul]

Konuya vakıf değrerli arkadaşlarımın görüş ve önerilerini bekliyorum

 

[Korhan Ayhan]

Selamlar,

Verileriniz düzenli satır artışları ile gitmediği için ben aşağıdaki şekilde bir çözüm yolu öneriyorum. Denermisiniz.

Option Explicit
 
Sub SAYFALARDA_ATLAYARAK_SATIR_SİL()
    Dim SAYFA As Worksheet, X As Long
    
    Application.ScreenUpdating = False
    
    For Each SAYFA In Worksheets
        With SAYFA
            For X = 1 To .Range("A65536").End(3).Row
                If Not IsNumeric(.Cells(X, 1)) Then .Cells(X, 1) = Empty
            Next
            .Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        End With
    Next
    
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[adnanyurdakul]

Sayın Korhan aydın
Örneğiniz sorunsuz çalışıyor.Yardımlarınız için çok teşekkürler. Sizlere zahmet veriyorum ama öğreenmek i,stediğim bir konu var
gönderdiğim örnekte
Range(hepsi).Select ki burada hepsi
1:16,77:93,154:170,231:247,308:324,385:401,462:478 ,539:555,616:632,693:709,770:786,847:863,924:940,1 001:1017,1078:1094,1155:1171,1232:1248,1309:1325,1 386:1402,1463:1479 aralığını ifade eder
for döngüsünde 2 e kadar problemsiz çalışıyor sonra
"RANGE OF OBJECT global failed " hatası veriyor.
bu hatayı neden verir çözümü nedir
Tekrar teşekkürler vereceğiniz emek için

 

[Korhan Ayhan]

Selamlar,

Sanırım seçtirmeye çalıştığınız aralık çok fazla olduğundan bu hatayı alıyorsunuz.

 

[adnanyurdakul]

teşekkürler
sağolun