• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

İçeriği 000 ve 0000 Başlayan rakamlar hariç Satırları sil.

S

sensizsoldum

Katılım
10 Ekim 2010
Mesajlar
1,469
Excel Vers. ve Dili
2010 Türkçe
Merhaba,
E3:E sütun aralığında Örnek dosyada ki gibi rakamlar bulunmaktadır. Yaklaşık 20bin hücreye tekâmül etmektedir. Benim istediğim E3:E sütun Aralığında ki rakamları içeren, rakamlardan 000 ve 0000 ile başlayanlar hariç diğer satırların, satır olarak çok hızlı bir biçimde bir buton yardımıyla makroda filtre yapılmadan silinmesi. Örnek dosaya belirlemek üzere ben verileri sıraladım. Normalde böyle sıralı olmuyor. Ben silinmesi gereken satırları kırmızı olarak belirledim.
Şimdiden teşekkür ederim, tüm form ailesine.
İyi günler dilerim.
 

Ekli dosyalar

Merhaba,
Değerli Hocalarım, arkadaşlarım, bu konuya bi çözüm üretebilir miyiz ?
iyi çalışmalar dilerim.
 
Satırları silmek yerine, 000 ve 0000 ile başlayanları ayrı sütunu alsak işinizi görür mü ?
 
Siz cevap vermiyorsunuz ama ben yine de kodları vereyim.

Belki birilerinin işine yarar...

Kod: 
Sub Emre_Satırlari_Sil()
    Dim i As Long
        For i = 1 To Range("E65536").End(3).Row
            If VBA.Left(Cells(i, "E"), 3) = "000" Then
                Rows(i).Delete
            End If
        Next i
    i = Empty
    MsgBox " ..::.. Silme işlemi tamamlandı ..::.. ", vbInformation + vbMsgBoxRtlReading, "Emre"
End Sub
Kod: 
Sub Emre_Normal_Ayir()
    Dim i As Long
        For i = 1 To Range("E65536").End(3).Row
            If VBA.Left(Cells(i, "E"), 3) = "000" Then
                Cells(i, "E").Copy Range("H65536").End(3)(2, 1)
            End If
        Next i
    i = Empty
    MsgBox " ..::.. Ayırma işlemi tamamlandı ..::.. ", vbInformation + vbMsgBoxRtlReading, "Emre"
End Sub
Kod: 
Sub Emre_Ado_Farki_ile_Ayir()
    Dim con As Object, rs As Object
    Dim dosya As String, sorgu As String
        Set con = CreateObject("adodb.connection")
        Set rs = CreateObject("adodb.recordset")
        dosya = ThisWorkbook.FullName
        con.Open "Provider=Microsoft.jet.oledb.4.0;data source=" & dosya & _
        ";extended properties=""excel 8.0;hdr=no"""
        sorgu = "Select F1 From [Sayfa1$] where [F1] like '000%'"
        rs.Open sorgu, con, 1, 1
        Range("H3").CopyFromRecordset rs
    MsgBox " ..::.. Ayırma işlemi tamamlandı ..::.. ", vbInformation + vbMsgBoxRtlReading, "Emre"
    dosya = vbNullString: sorgu = vbNullString: Set rs = Nothing: Set con = Nothing
End Sub
 
Son düzenleme:
Merhaba Murat Bey, Öncelikle çok teşekkür ederim ilginiz için.
Araştırma yapıyordum o yüzden bakamadım. Maalesef oldu yerde 000 ve 0000 ile başlayan rakamlar hariç satır olarak silinmesi gerekmekte. Bu kodu ekleyeceğim sayfa sisteme bağlı olarak çalışıyor. A ve I sütunlar arasında veriler var. Ben bunları süzmeye çalışıyorum bu şekilde. Yazdığınız kodları denemedim henüz cevap yazmaktan dolayı umarım istediğim gibi ve hızlı bir yöntem olmuştur. Bu arada sormadan edemeyeceğim. Ado nedir. Açılımını merak ediyorum.
Hemen kodlarınızı deniyorum. İyi çalışmalar dilerim.
 
Sonuca göre tekrar yazarsınız...
Bekliyorum.
 
evet, ben yeni mesajlara bakarak ileride bana da problem çıkarma ihtimali olanları takip ediyorum, 3 seçenek sunmuşsunuz ve hepside güzeldi bize sadece kendi listemize uygun olarak düzenlemek kalıyor teşekkürler, benim işime yarar en azından.
 
Siz mi çok hızlısınız yoksa Osman Bey mi çok yavaş acaba ?
Karar veremedim şu an ? :D

Kodları zaten birilerinin işine yarasın diye yazıyoruz.;-)

Evet 3 seçenek sundum ama henüz bir cevap alamadım...
 
Merhaba Murat Bey
Kodları denedim fakat 3 kod system error hatası verdi onu deneyemedim. 2 kod ise yaklaşık 5 dk. Kadar zaman işlem yaptı. Ne gibi bir sonuç verdi göremedim. Onu zorla kapadım ilk kod istediğim gibi, ama ben içeriği 000 ve 0000 3 ve 4 sıfır ile başlayanlar hariç satır olarak silinsin istiyorum. İçeriği 9, 8 vs gibi rakamlarla başlayanlar silinmiyor :( bu şekilde de düzenleme yapılabilir mi. Yani şartı 000 ve 0000 3 ve 4 sıfırla başlayanlar hariç satır olarak silinmeli. Bunu biraz daha hızlandırabilirsek sevinirim,
Her şey için teşekkür ederim.
Saygılarımla.



Sub Emre_Satırlari_Sil()
Application.ScreenUpdating = False
Dim i As Long
For i = 1 To Range("E65536").End(3).Row
If VBA.Left(Cells(i, "E"), 3) = "000" Then
Rows(i).Delete
End If
Next i
i = Empty
Application.ScreenUpdating = True
End Sub
 
Anladım.. yine aynı sorun...
Bir kere sorun çıktı mı, ne yazık ki çözülemiyor.

Benden bu kadar !

İyi akşamlar...
 
Merhaba Murat Bey, ben kodu denedim cevapta yazdım inanın çok özür dilerim. Başka konuya mı gitti başka bir yere mi ekledim anlamadım gitti. Gerçekten çok özür dilerim. İlk kod tam olarak değil de kısmen istediğim gibi 2 kod çok uzun bir çalışma yaptı sonuç alamadım exceli zorla kapadım. 3 kod ise sistem error hatası veriyor.
ilk kodu denediğimde 9,8, 7 vs. gibi başlayan rakamları silmiyor. Kodu son olarak aşağıda ki gibi kendime göre uyarladım. Hızlı olması için eklentiler yaptım bu hız çalışmaya yetmiyor. Daha hızlı ve diğer istenilen verilere ait satırları silmek için de iyileştirme olabilir mi?







Sub Emre_Satırlari_Sil()
Application.ScreenUpdating = False
Dim i As Long
For i = 1 To Range("E65536").End(3).Row
If VBA.Left(Cells(i, "E"), 3) = "000" Then
Rows(i).Delete
End If
Next i
i = Empty
Application.ScreenUpdating = True
End Sub
 
Merhaba,

Aşağıdaki kodu denermisiniz.

Eklediğiniz dosyada test ettiğimde 1 saniye gibi bir sürede işlem tamamlandı.

Kod: 
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, 5).End(3).Row
    If Satir < 3 Then Exit Sub
 
    If Satir = 3 Then
        If Left(Cells(Satir, "E"), 3) <> "000" And Left(Cells(Satir, "E"), 4) <> "0000" Then
            Rows(Satir).Delete
        End If
    Else
 
        Veri = Range("E3:E" & Satir).Value
 
        ReDim Dizi(UBound(Veri))
 
        For X = 1 To UBound(Veri)
            Dizi(X) = Veri(X, 1) & "#E" & X + 2
        Next
 
        For X = 3 To UBound(Dizi) + 2
            If Left(Dizi(X - 2), 3) <> "000" And Left(Dizi(X - 2), 4) <> "0000" 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
 
Merhaba Korhan Bey,
Günaydın Hayırlı sabahlar,
Korhan bey mükemmel ötesi olmuş, yine harikalar yapmışsınız, eline bilgine sağlık. Çok teşekkür ederim. Murat bey e de ilgi ve alakalından dolayı çok teşekkür ederim. Günümün büyük kısmını süzme işlemi yaparak geçiriyordum sayenizde bir klik le bu işler tamam oluyor. Allah’ım sizlerden razı olsun. Her şey gönlünüzce olması umuduyla.
Mutlu günler dilerim.
Saygılarımla.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst