Koşullu Satır Silme

xternet · 22 Aralık 2019

Merhaba Arkadaşlar
Koşullu satır silmeye dair bir çok başlık buldum ama istediğimi oluşturamadım.
Yardımcı olursanız memnun olurum.

En çok 3 şartlı satır silme yapmak istiyorum.
Örneğin;
A1 hücresindeki değeri D sutununda,
B1 hücresindeki değeri E sutununda,
C1 hücresindeki değeri F sutununda arayıp,
bu 3 şartı sağlayan satırları komple silmesini istiyorum.
Bu 3 şarttan 1 yada 2 si boş hücre ise, dolu olan 1 yada 2 şarta göre işlemi yine yapmalı.

Hücrelerdeki şartları UserForm üzerinden gireceğim için
kod hangi sayfada çalıştırılırsa çalışsın, bu işlemi bilinen sayfada yapmalı.
Örneğin "DEPO" sayfasında bu işlemi yapıcak.

İlgilenecek arkadaşlara şimdiden çok teşekkür ediyorum.
İyi çalışmalar.

EmrExcel16 · 22 Aralık 2019

xternet' Alıntı:
Merhaba Arkadaşlar
Koşullu satır silmeye dair bir çok başlık buldum ama istediğimi oluşturamadım.
Yardımcı olursanız memnun olurum.

En çok 3 şartlı satır silme yapmak istiyorum.
Örneğin;
A1 hücresindeki değeri D sutununda,
B1 hücresindeki değeri E sutununda,
C1 hücresindeki değeri F sutununda arayıp,
bu 3 şartı sağlayan satırları komple silmesini istiyorum.
Bu 3 şarttan 1 yada 2 si boş hücre ise, dolu olan 1 yada 2 şarta göre işlemi yine yapmalı.

Hücrelerdeki şartları UserForm üzerinden gireceğim için
kod hangi sayfada çalıştırılırsa çalışsın, bu işlemi bilinen sayfada yapmalı.
Örneğin "DEPO" sayfasında bu işlemi yapıcak.

İlgilenecek arkadaşlara şimdiden çok teşekkür ediyorum.
İyi çalışmalar.

Ekteki dosyayı deneyiniz.
Dosyanız da Userform olmadığı için bir butona ekledim kodları. Şartlarınıza uyan satırları belirliyor eğer satırların silinmesini istiyorsanız 'Call Sil_satir başındaki tırnağı kaldırın.

Kod:

Option Explicit
Sub Sartli_Satir_Sil()
    Dim Rng, Srt1, Srt2, c, firstAddress
    Application.ScreenUpdating = False
    Range("C5:C10000").Clear
    If Range("A1") <> "" Then
        Set Rng = Range(Range("D5"), Range("D" & Cells(Rows.Count, 4).End(3).Row))
        Srt1 = "nok"
        Srt2 = "nok"
        With Rng
             Set c = .Find(Range("A1"), LookIn:=xlValues)
             If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    If Range("B1") <> "" Then
                        If Range("B1") = Cells(c.Row, 5) Then
                            Srt1 = "ok"
                        Else
                            Srt1 = "nok"
                        End If
                    Else
                        Srt1 = "ok"
                    End If
                    If Range("C1") <> "" Then
                        If Range("C1") = Cells(c.Row, 6) Then
                            Srt2 = "ok"
                        Else
                            Srt2 = "nok"
                        End If
                    Else
                        Srt2 = "ok"
                    End If
                    If Srt1 = "ok" And Srt2 = "ok" Then
                        Cells(c.Row, 3).Interior.Color = 255
                        Cells(c.Row, 3) = "Silinecek"
                    End If
                    Set c = .FindNext(c)
                    If c Is Nothing Then
                        GoTo bitir1
                    End If
                Loop While c.Address <> firstAddress
            End If
bitir1:
        End With
    ElseIf Range("B1") <> "" Then
        
        Set Rng = Range(Range("E5"), Range("E" & Cells(Rows.Count, 5).End(3).Row))
        Srt1 = "nok"
        Srt2 = "nok"
        With Rng
             Set c = .Find(Range("B1"), LookIn:=xlValues)
             If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    If Range("A1") <> "" Then
                        If Range("A1") = Cells(c.Row, 4) Then
                            Srt1 = "ok"
                        Else
                            Srt1 = "nok"
                        End If
                    Else
                        Srt1 = "ok"
                    End If
                    If Range("C1") <> "" Then
                        If Range("C1") = Cells(c.Row, 6) Then
                            Srt2 = "ok"
                        Else
                            Srt2 = "nok"
                        End If
                    Else
                        Srt2 = "ok"
                    End If
                    If Srt1 = "ok" And Srt2 = "ok" Then
                        Cells(c.Row, 3).Interior.Color = 255
                        Cells(c.Row, 3) = "Silinecek"
                    End If
                    Set c = .FindNext(c)
                    If c Is Nothing Then
                        GoTo bitir2
                    End If
                Loop While c.Address <> firstAddress
            End If
bitir2:
        End With
    
    ElseIf Range("C1") <> "" Then
        Set Rng = Range(Range("F5"), Range("F" & Cells(Rows.Count, 6).End(3).Row))
        Srt1 = "nok"
        Srt2 = "nok"
        With Rng
             Set c = .Find(Range("C1"), LookIn:=xlValues)
             If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    If Range("A1") <> "" Then
                        If Range("A1") = Cells(c.Row, 4) Then
                            Srt1 = "ok"
                        Else
                            Srt1 = "nok"
                        End If
                    Else
                        Srt1 = "ok"
                    End If
                    If Range("B1") <> "" Then
                        If Range("B1") = Cells(c.Row, 5) Then
                            Srt2 = "ok"
                        Else
                            Srt2 = "nok"
                        End If
                    Else
                        Srt2 = "ok"
                    End If
                    If Srt1 = "ok" And Srt2 = "ok" Then
                        Cells(c.Row, 3).Interior.Color = 255
                        Cells(c.Row, 3) = "Silinecek"
                    End If
                    Set c = .FindNext(c)
                    If c Is Nothing Then
                        GoTo bitir3
                    End If
                Loop While c.Address <> firstAddress
            End If
bitir3:
        End With
    End If
    'Call Sil_satir
    MsgBox "Islem Tamam"
    Application.ScreenUpdating = True
End Sub

Sub Sil_satir()
    With Range(Range("C5"), Range("C" & Cells(Rows.Count, 3).End(3).Row))
    Set c = .Find("Silinecek", LookIn:=xlValues)
    If Not c Is Nothing Then
        Do
            Rows(c.Row).Delete Shift:=xlUp
            Set c = .Find("Silinecek", LookIn:=xlValues)
        Loop While Not c Is Nothing
    End If
    End With
End Sub

xternet · 22 Aralık 2019

Öncelikle emeğiniz için çok teşekkür ederim.
Düşündüğümden uzun bir kod.
Kod "silinecek" satırları sorunsuz seçiyor yalnız, "call sil_satir" ifadesini aktif ettiğimde resimdeki hatayı veriyor.

Korhan Ayhan · 23 Aralık 2019

Bahsettiğiniz A1-B1-C1 hücreleri sıralı şekilde mi dolu olacak? Yoksa A1 ve C1 dolu olma ihtimali var mı?

Sıralı koşul için aşağıdaki kodu deneyiniz.

Kod:

Option Explicit

Sub Kosula_Gore_Satir_Sil()
    Dim S1 As Worksheet, Aranan As String, Veri As Variant
    Dim Son As Long, X As Long, Alan As Range
    
    Set S1 = Sheets("DEPO")
    
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    
    Son = S1.Cells(S1.Rows.Count, 4).End(3).Row
    Veri = S1.Range("D6:F" & Son).Value
    
    If S1.Range("A1").Value <> "" Then
        If Aranan = "" Then
            Aranan = "#" & S1.Range("A1").Value & "#"
        Else
            Aranan = Aranan & S1.Range("A1").Value & "#"
        End If
    End If
    
    If S1.Range("B1").Value <> "" Then
        If Aranan = "" Then
            Aranan = "#" & S1.Range("B1").Value & "#"
        Else
            Aranan = Aranan & S1.Range("B1").Value & "#"
        End If
    End If
    
    If S1.Range("C1").Value <> "" Then
        If Aranan = "" Then
            Aranan = "#" & S1.Range("C1").Value & "#"
        Else
            Aranan = Aranan & S1.Range("C1").Value & "#"
        End If
    End If
    
    For X = 1 To UBound(Veri)
        If InStr(1, "#" & Veri(X, 1) & "#" & Veri(X, 2) & "#" & Veri(X, 3) & "#", Aranan) > 0 Then
            If Alan Is Nothing Then
                Set Alan = Range("A" & X + 5)
            Else
                Set Alan = Union(Alan, Range("A" & X + 5))
            End If
        End If
    Next
    
    If Not Alan Is Nothing Then
        Alan.EntireRow.Delete
        MsgBox "Seçtiğiniz koşullara uyan satırlar silinmiştir.", vbInformation
    Else
        MsgBox "Seçtiğiniz koşullara uygun kayıt bulunamamıştır!", vbExclamation
    End If
End Sub

EmrExcel16 · 23 Aralık 2019

xternet' Alıntı:
Öncelikle emeğiniz için çok teşekkür ederim.
Düşündüğümden uzun bir kod.
Kod "silinecek" satırları sorunsuz seçiyor yalnız, "call sil_satir" ifadesini aktif ettiğimde resimdeki hatayı veriyor.

Rica ederim.

Hata veren yere Dim tanımlaması eklemeyi unutmuşum .

Sub Sil_satir() satırının altına Dim c bu satırı ekleyin sorun düzelir.

Makro her çalışmasında tüm kod satırlarına girmiyor 3 adet sorgu var , hangisine uyarsa onu gerçekleştiriyor , yani verdiğim kodların her çalışmada 3/1 çalışıyordu bu şartları değişken olarak tanımlarsak kod kısalır , bu şekildeki değişken olarak tanımladığım kodu ve dosyayı da ekliyorum.

Kod:

Option Explicit
Sub Sartli_Satir_Sil()
    Dim Rng, Srt, Srt1, Srt2, c, firstAddress, SrtDrm1, SrtDrm2, Ara1, Ara2
    Application.ScreenUpdating = False
    Range("C5:C10000").Clear
    SrtDrm1 = "nok"
    SrtDrm2 = "nok"
    If Range("A1") <> "" Then
        Set Rng = Range(Range("D5"), Range("D" & Cells(Rows.Count, 4).End(3).Row))
        Srt = Range("A1")
        Srt1 = Range("B1")
        Srt2 = Range("C1")
        Ara1 = 5
        Ara2 = 6
    ElseIf Range("B1") <> "" Then
        Set Rng = Range(Range("E5"), Range("E" & Cells(Rows.Count, 5).End(3).Row))
        Srt = Range("B1")
        Srt1 = Range("A1")
        Srt2 = Range("C1")
        Ara1 = 4
        Ara2 = 6
    ElseIf Range("C1") <> "" Then
        Set Rng = Range(Range("F5"), Range("F" & Cells(Rows.Count, 6).End(3).Row))
        Srt = Range("C1")
        Srt1 = Range("A1")
        Srt2 = Range("B1")
        Ara1 = 4
        Ara2 = 5
    End If
    
    If Srt <> "" Or Srt1 <> "" Or Srt2 <> "" Then
    
        With Rng
             Set c = .Find(Srt, LookIn:=xlValues)
             If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    If Srt1 <> "" Then
                        If Range("B1") = Cells(c.Row, Ara1) Then
                            SrtDrm1 = "ok"
                        Else
                            SrtDrm1 = "nok"
                        End If
                    Else
                        SrtDrm1 = "ok"
                    End If
                    If Srt2 <> "" Then
                        If Range("C1") = Cells(c.Row, Ara2) Then
                            SrtDrm2 = "ok"
                        Else
                            SrtDrm2 = "nok"
                        End If
                    Else
                        SrtDrm2 = "ok"
                    End If
                    If SrtDrm1 = "ok" And SrtDrm2 = "ok" Then
                        Cells(c.Row, 3).Interior.Color = 255
                        Cells(c.Row, 3) = "Silinecek"
                    End If
                    Set c = .FindNext(c)
                    If c Is Nothing Then
                        GoTo bitir
                    End If
                Loop While c.Address <> firstAddress
            End If
bitir:
        End With
        'Call Sil_satir
    End If
    MsgBox "Islem Tamam"
    Application.ScreenUpdating = True
End Sub

Sub Sil_satir()
    Dim c
    With Range(Range("C5"), Range("C" & Cells(Rows.Count, 3).End(3).Row))
    Set c = .Find("Silinecek", LookIn:=xlValues)
    If Not c Is Nothing Then
        Do
            Rows(c.Row).Delete Shift:=xlUp
            Set c = .Find("Silinecek", LookIn:=xlValues)
        Loop While Not c Is Nothing
    End If
    End With
End Sub

xternet · 23 Aralık 2019

Arkadaşlar bilgiler için çok teşekkür ediyorum.
Daha basit olarak 1 şarta bağlı silme işlemini nasıl yapabilirim.
Örneğin A1 hücresindeki değere göre C sutununda arama yapıcak ve A1 değerine sahip satırları listeden çıkarıcak.

Aşağıdaki kodu bir çalışmamda kullanıyorum
For k = 1 To 3000
If Range("A" & k) = "" Then
Rows(k).Select
Selection.ClearContents
End If
Next k

Anlaşılacağı üzere a sutunundaki boş satırlara göre tüm satırı temizliyor.

Buradaki
"Selection.ClearContents" ifadesi yerine

"Selection.EntireRow.Delete" yazıp zynı işi görürüm belki dedim ama olmadı.

EmrExcel16 · 23 Aralık 2019

Arama yapmak için 3000 satirlik bir dönğüye gerek yok, find yöntemi ile nokta atışı yapabilirsiniz , son dosya için bir yorum yapmadiz ama biraz uğraşırsaniz son gönderdiğım dosyayi ve kodlari kendinize ğöre uyarlayabilirsiniz 2. ve 3. şartlari sileceksiniz.

xternet · 23 Aralık 2019

EmrExcel16' Alıntı:
Arama yapmak için 3000 satirlik bir dönğüye gerek yok, find yöntemi ile nokta atışı yapabilirsiniz , son dosya için bir yorum yapmadiz ama biraz uğraşırsaniz son gönderdiğım dosyayi ve kodlari kendinize ğöre uyarlayabilirsiniz 2. ve 3. şartlari sileceksiniz.

Son dosyanız sorunsuz çaılışıyor Sayın EmrExcel16, teşekkürler
Tek şarta uyarlamaya çalışacağım.

EmrExcel16 · 23 Aralık 2019

xternet' Alıntı:
Son dosyanız sorunsuz çaılışıyor Sayın EmrExcel16, teşekkürler
Tek şarta uyarlamaya çalışacağım.

Hatta bir ipucu daha vereyim sart tek ise daha önceki verdiğim kod bloğundan sadece aşağidaki kisim sizin için yeterli. "Silinecek" yazan yerleri Range("A1") olarak değiştirin. Diğer kodlara gerek yok.

Kod:

Sub Sil_satir()
    Dim c
    With Range(Range("C5"), Range("C" & Cells(Rows.Count, 3).End(3).Row))
    Set c = .Find(Range("A1"), LookIn:=xlValues)
    If Not c Is Nothing Then
        Do
            Rows(c.Row).Delete Shift:=xlUp
            Set c = .Find(Range("A1"), LookIn:=xlValues)
        Loop While Not c Is Nothing
    End If
    End With
End Sub

xternet · 23 Aralık 2019

Teşekkürler Sayın EmrExcel16

Bu arada az önce denediğim kodun da aslında çalıştığını keşfettim.
Sorun çalışmaya koyduğum korumaymış.
Yazdığım kodların önüne ve arkasına koruma kaldırma ve ekleme koyarım hep.
Bu kodun önünde koruma kaldırma olmadığı için sorun çıkarıyormuş.

Zaman ayırdığınız için çok teşekkür ederim tekrar.
İyi çalışmalar.

For i = 11 To [C10]

If Range("K" & i) = Range("A1") Then
Rows(i).Select
Selection.EntireRow.Delete
End If

Next i

EmrExcel16 · 23 Aralık 2019

Rica ederim , nasil ve hangisini kullanmak isterseniz tercih sizin.

Koşullu Satır Silme

xternet

Ekli dosyalar

EmrExcel16

Destek Ekibi

Ekli dosyalar

xternet

Ekli dosyalar

Korhan Ayhan

Administrator

EmrExcel16

Destek Ekibi

Ekli dosyalar

xternet

EmrExcel16

Destek Ekibi

xternet

EmrExcel16

Destek Ekibi

xternet

EmrExcel16

Destek Ekibi