1 hariç Diğer satıları sil..!

[sensizsoldum]

Merhaba,
I3:I sütun aralığında tek karakter olmak üzere rakam ve harf olarak veriler bulunmaktadır. Yaklaşık 20bin hücreye tekâmül etmektedir. Benim istediğim I3:I sütun Aralığında 1 rakamı olan hariç diğer satırların, satır olarak çok hızlı bir biçimde bir buton yardımıyla silinmesi.
Şimdiden teşekkür ederim, tüm form ailesine. İyi geceler dilerim

 

[uzmanamele]

Merhaba

2 farklı makrodan birini kullanabilirsiniz.

Sub BirHaricSil()
For i = Range("ı65536").End(3).Row To 3 Step -1
If Cells(i, "I") <> 1 Then
Rows(i).Delete
End If
Next
End Sub

Sub FiltreleyerekSil()
    Range("I2").Select
    Selection.AutoFilter
    ActiveSheet.Range("$I$2:$I$65536").AutoFilter Field:=1, Criteria1:="<>1", Operator:=xlAnd
    Rows("3:65536").Select
    Selection.Delete Shift:=xlUp
    Range("I2").Select
    Selection.AutoFilter
End Sub

Esasen bunu makrosuz da kısa sürede yapabilirsiniz. (2. makro kodu bu işlemi yapar)
I2 ye filtre uygulayın, özel filtre kriteri "eşit değil 1"
geriye kalan satırları seçip silin ve filtreyi kaldırın.

 

[ExcelF1]

Sayın uzmanamele Hocam cevap vermişler. Bende yazmışken ekleyeyim.

Sub Düğme1_Tıklat()
Application.ScreenUpdating = False
For a = [I65536].End(xlUp).Row To 3 Step -1
If Cells(a, 9) <> 1 Then Cells(a, 9).EntireRow.Delete shift:=xlUp
Next a
Application.ScreenUpdating = True
End Sub

 

[sensizsoldum]

Merhaba Günaydın, Hayırlı sabahlar,
Çok tşk ederim, elinize bilginize sağlık. İyi çalışmalar dilerim.

 

[sensizsoldum]

Merhaba, iyi akşamlar.
I3:I Sütunları arasında 1 olan hariç diğer satırlar silinsin istemiştim verdiğiniz kodları ilk denediğimde doğru sonuç alıyordum ancak şimdi.
Compile error:
Variable not defined resimdeki gibi hata alıyorum. Diğer taraftan uzman hocamızın kodunda da aynı hatayı alıyorum. Bu durumda ne yapmam gerekli.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki linki inceleyin.

Nedir şu Option Explicit-Option Base-Option Compare

 

[sensizsoldum]

Merhaba Korhan Bey,
Konuya göz attım hata düzeldi. Çok Teşekkür ederim, yalnız çok fazla sayıda veri satırı silindiğinden aşağıda verdiğim kod, istediğim gibi hızda silmiyor 45 sn. civarında işlem bitiriyor.diğer kodlarda bu şekilde. Bu kodu daha hızlı bir şekilde uyarlayabilmek mümkünümdür.



Sub sil()
Application.ScreenUpdating = False
For a = [I65536].End(xlUp).Row To 3 Step -1
If Cells(a, 9) <> 1 Then Cells(a, 9).EntireRow.Delete shift:=xlUp
Next a
Application.ScreenUpdating = True
End Sub

 

[ExcelF1]

uzmanamele hocamın kodlarını deneyiniz. 2 sn. sürmez.

Sub FiltreleyerekSil()
Range("I2").Select
Selection.AutoFilter
ActiveSheet.Range("$I$2:$I$65536").AutoFilter Field:=1, Criteria1:="<>1", Operator:=xlAnd
Rows("3:65536").Select
Selection.Delete Shift:=xlUp
Range("I2").Select
Selection.AutoFilter
End Sub

 

[sensizsoldum]

Merhaba günaydın hayırlı sabahlar,
Sayın ExcelF1 ilgi ve alakanıza teşekkür ederim. Filtre olarak işlem yapıldığında nedendir anlamıyorum. Hata alıyorum. Ya da bundan sonraki süzme işlemlerine engel oluyor. Sayın uzman hocamızın ilk yazdığı kod ya da sizin verdiğiniz kodu kullanmak istiyorum. Ama dediğim gibi çok uzun zamanda işlem yapıyor. Evde 45 sn. şirkette sanırsam 2 dk. kadar zaman sürer. Ben bunun gibi yaklaşık 10 tane süzme işlemi yapacağımdan kodların işlemi bu yüzden çok hızlı sürede yapmasını istiyorum. Her kod 1 dk. İşlem yaptığını var sayarsak 10 dk.
Tekrardan teşekkür ederim iyi çalışmalar dilerim.

 

[Korhan Ayhan]

Merhaba,

Alternatif olarak aşağıdaki kodu denermisiniz.

Kod içindeki "Katsayi" değeri ile oynayıp işlem süresini test edebilirsiniz.

Sizin bilgisayarınıza göre hangi katsayı uygunsa onu kullanırsınız.

Ben 2000 satırlık bloklar halinde denedim. Yaklaşık 8-10 saniye arasında işlemi tamamladı.

Option Explicit
Option Base 1
 
Sub Koşullu_Satır_Sil()
    Dim Veri(), Dizi(), Alan As Range, Satir As Long
    Dim X1 As Long, X2 As Integer, X3 As Integer
    Dim Zaman As Date, Say As Long, Katsayi As Integer
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    Zaman = Time
    Katsayi = 2000
 
    Satir = Cells(Rows.Count, "I").End(3).Row
    If Satir < 3 Then Exit Sub
 
10
 
    If Satir = 3 Then
        If Cells(Satir, "I") <> 1 Then
            Rows(Satir).Delete
        End If
    Else
 
        For X1 = 3 To Satir Step Katsayi
 
            Veri = Range("I" & X1 & ":I" & X1 + Katsayi - 1).Value
 
            ReDim Dizi(UBound(Veri))
            Say = X1
 
            For X2 = 1 To UBound(Veri)
                Dizi(X2) = Veri(X2, 1) & "#I" & Say
                Say = Say + 1
            Next
 
            For X3 = 3 To UBound(Veri) + 2
                If Split(Dizi(X3 - 2), "#")(0) <> "1" Then
                    If Alan Is Nothing Then
                        Set Alan = Range(Split(Dizi(X3 - 2), "#")(1))
                    Else
                        Set Alan = Application.Union(Alan, Range(Split(Dizi(X3 - 2), "#")(1)))
                    End If
                End If
            Next
 
            If Not Alan Is Nothing Then
                Alan.EntireRow.Delete
                Erase Veri
                Erase Dizi
                Set Alan = Nothing
            End If
        Next
    End If
 
    Say = WorksheetFunction.CountIf(Range("I3:I" & Cells(Rows.Count, "I").End(3).Row), "<>" & 1)
    If Say > 0 Then GoTo 10
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi; " & Format(Time - Zaman, "hh:mm:ss"), vbInformation
End Sub

 

[sensizsoldum]

Merhaba Korhan Bey,
Satır sil ile alakalı tek bir sorun kaldı. Sekiz ayrı sütundan verilere göre satır silme işlemi maksimum 5 Sn. kadar bir sürede yapıyor. Sadece I3:GIsütun aralığında bulunan rakamsal verilerden 1 hariç olanları satır olarak silme işlemi olan kodlarda hata alıyorum bir üst mesajdaki #10 kodu linkte verdiğim #13 mesajınızda bulunan kod gibi yazarsak sanırsam çalışmada sorun diye bir şey kalmayacak.
Link aşağıdadır.

http://www.excel.web.tr/f48/satyr-sil-t115473.html


İlgi ve alakanıza teşekkür ederim iyi çalışmalar dilerim.
Saygılarımla.

 

[sensizsoldum]

Son olarak kodu aşağıdaki gibi yaptım lakin ne var ne yok herşeyi siliyor.
anlamadım gitti.











Sub Seven()
Dim Veri(), X, Dizi(), Alan As Range, Satir As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Satir = Cells(Rows.Count, 9).End(3).Row
If Satir < 3 Then Exit Sub

If Satir = 3 Then
If UCase(Left(Cells(Satir, "I"), 2)) <> "1" Then
Rows(Satir).Delete
End If
Else

Veri = Range("I3:I" & Satir).Value

ReDim Dizi(UBound(Veri))

For X = 1 To UBound(Veri)
Dizi(X) = Veri(X, 1) & "#I" & X + 2
Next

For X = 3 To UBound(Dizi) + 2
If UCase(Left(Dizi(X - 2), 2)) <> "I" Then
If Alan Is Nothing Then
Set Alan = Range(Split(Dizi(X - 2), "#")(1))
Else
Set Alan = Application.Union(Alan, Range(Split(Dizi(X - 2), "#")(1)))
End If
End If
Next

If Not Alan Is Nothing Then
Alan.EntireRow.Delete
End If
End If

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

 

[snx111]

Sub Koşullu_Satır_Snxf()
    Dim Satir As Long
    y = 0
 Application.ScreenUpdating = False
10     On Error Resume Next
    Satir = Cells(Rows.Count, 2).End(3).Row
    If Satir < 3 Then Exit Sub
    
    If Satir > 3 Then
    For X = 2 To Satir
    Cells(X, "g") = WorksheetFunction.Text(Cells(X, 7), "#")
        If Cells(X, "g") <> "1" Or Cells(X, "g") <> 1 Or Cells(X, "g") > 1 Then

            Rows(X).Delete
        End If
    
    Next
   End If
   y = y + 1: Beep
   If y >= 10 Then Exit Sub
   If y < 11 Then GoTo 10
End Sub

 

[snx111]

Merhaba

2 farklı makrodan birini kullanabilirsiniz.

Sub BirHaricSil()
For i = Range("ı65536").End(3).Row To 3 Step -1
If Cells(i, "I") <> 1 Then
Rows(i).Delete
End If
Next
End Sub

silinecek satırları tektek buldukça silmek yerine hafızada cells adresini yani row adresini tutsakta mesela rows 1 3 33 45 67 68 69 ... hepsini bir anda sildirsek zamandan kazanırmıyız ; bu dediğim silinecek satırları bekletme ile yapabilirmiyiz? olursa örnek verirmi siniz

 

[uzmanamele]

Merhaba

2 farklı makrodan birini kullanabilirsiniz.

Sub BirHaricSil()
For i = Range("ı65536").End(3).Row To 3 Step -1
If Cells(i, "I") <> 1 Then
Rows(i).Delete
End If
Next
End Sub

silinecek satırları tektek buldukça silmek yerine hafızada cells adresini yani row adresini tutsakta mesela rows 1 3 33 45 67 68 69 ... hepsini bir anda sildirsek zamandan kazanırmıyız ; bu dediğim silinecek satırları bekletme ile yapabilirmiyiz? olursa örnek verirmi siniz

Merhaba
Bence en hızlı yöntem; filtreleyerek silmektir. Bunu bir kaç bin veri içeren bir dosyada test ediniz. 2. mesajdaki 2. kod bunu yapar.

Önce tespit edip sonra silmek işi hızlandırmaz, aksine yavaşlatır.
Çünkü kod önce kritere uyanları tespit etmek için tüm veriyi tarayacak, uyanları aklında tutacak, sonra aklında tuttuğu satırları silmek için tekrar çalışacak.
Bunun nasıl olduğunu aşağıdaki kod ile görebilirsiniz.
Yine bir kaç bin veri içeren bir dosyada deneyerek görebilirsiniz.
Çok fazla veri içeriyorsa msgbox satırını siliniz.

Dim a(1000) As Double

1000 adet veri olabileceği düşünülmüştür.

Sub BirHaricBul()
For i = 3 To Range("ı65536").End(3).Row
If Cells(i, "I") <> 1 Then
a(i) = i
End If
Next
End Sub

Sub BirHaricYaz()
For j = Range("ı65536").End(3).Row To 3 Step -1
If a(j) > 0 Then
MsgBox j & " satırı silinecek"
Rows(j).Delete
End If
Next j
End Sub

Not:
syn sensizsoldum, aşağıdaki satırı değiştirerek deneyiniz.

If UCase(Left(Cells(Satir, "I"), 2)) <> "1" Then

If UCase(Left(Cells(Satir, "I"), 2)) <> 1 Then

"1" yazarsanız bunu metin olarak alır, sizin veriniz sayısal ise 1 sayısının yazılı olduğu satırı da silecektir.
Test etmedim ama bu şekilde olduğunu düşünüyorum.

 

[snx111]

msgbox uyarısı alamadım ? j hep 0. hücre belirtilmediğinden sanırım ama ben sorduğum soruya cevap aramıştım ;

silinecek satırları hücreye yazmadan pc nin ram inde hafızada tutabilirmiyiz rows 1 2 3 44 55 56 57 58 şekilinde ve hepsini birden sil komutunu nasıl veririz şeklindeydi ;mümkünse bunu öğrenmek isityorum .

not ; konunun yeri bura olmadıgından yeni konu açacağım

 

[Korhan Ayhan]

Merhaba,

Benim önerdiğim #10 nolu mesajımdaki kod silinecek satırları redim ile hafızada tutup siliyor. Ama uygulamada en hızlı yöntem filtre uygulanarak silme yöntemidir.

 

[sensizsoldum]

Merhaba, Günaydın, Hayırlı sabahlar.
Daha önceki mesajlarımda da belirttiğim gibi… Filtreleme yaparak silmek çalışmada sorun çıkarıyor. Korhan beyde kodlarda ki değişikliği bu yüzden yaptı diye biliyorum. Korhan beyinde verdiği ilk kod yöntemi filtre yaparak silmekti. Diğer kodlar işlemi çok hızlı ve sağlıklı bir şekilde yapıyor. Sekiz sütundan ayrı ayrı verilere göre satır silme işlemi 3 sn. kadar bir zamanda yapıyor. Bu yüzden bu kodu tercih ediyorum. Son olarak I3:I aralığında ki veri silme işlemini #12 nolu mesajdaki koda uyarlayabilirsek çok sevineceğim.
Sayın uzman hocam verdiğiniz koddaki yerleri değiştirdim sonuç yine aynı. Tüm her şey siliniyor.
İyi çalışmalar dilerim.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu kullanabilirsiniz. Fakat ben yinede #10 nolu mesajımdaki kodu kullanmanızı tavsiye ederim.

Option Explicit
Option Base 1
 
Sub Koşullu_Satır_Sil()
    Dim Veri(), X, Dizi(), Alan As Range, Satir As Long
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    Satir = Cells(Rows.Count, "I").End(3).Row
    If Satir < 3 Then Exit Sub
 
    If Satir = 3 Then
        If Cells(Satir, "I") <> 1 Then
            Rows(Satir).Delete
        End If
    Else
 
        Veri = Range("I3:I" & Satir).Value
 
        ReDim Dizi(UBound(Veri))
 
        For X = 1 To UBound(Veri)
            Dizi(X) = Veri(X, 1) & "#I" & X + 2
        Next
 
        For X = 3 To UBound(Dizi) + 2
            If Split(Dizi(X - 2), "#")(0) <> "1" Then
                If Alan Is Nothing Then
                    Set Alan = Range(Split(Dizi(X - 2), "#")(1))
                Else
                    Set Alan = Application.Union(Alan, Range(Split(Dizi(X - 2), "#")(1)))
                End If
            End If
        Next
 
        If Not Alan Is Nothing Then
            Alan.EntireRow.Delete
        End If
    End If
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[sensizsoldum]

Merhaba Korhan Bey,
İlgi ve alakanıza teşekkür ederim. Filtreleme yöntemi benim çalışmaya niyeyse ters geliyor. Niye tercih etmemi istiyorsunuz anlayamadım. Şunu demek istiyorum. Son yazdığınız kodu denedim sıralama olmadan mükemmel çalışıyor. Hatta işlemi saniye değil, saliseler içinde sonuçlandırıyor.
Günlük ortalama 15 defa yapılan her süzme işlemini 10 dk. yapıyordum. Bu kodlarla süzmenin tamamını 3 ve 5 saniye arasına sayenizde indirmiş olduk. Aradaki farkı siz hesaplayın. Kazanılan zamanı ve sağlıklı sonuçlar. Bence sonuç mükemmel ötesi.
Sayın Korhan Bey ve diğer tüm hocalarıma arkadaşlarıma sonsuz teşekkür ederim.
Güzel günleri hayal edip, huzurla yaşaya bilme hayaliyle.
Saygılarımla.