4 sütunda 0 içeren satırı silme

[serif_007]

Merhabalar. Ekteki dosyayı örnek olarak hazırladım. B,C,D,E sütunlarında 4 sütununda "0" olması durumunda satırı silecek bir makroya ihtiyacım var. Bu 4 sütunda 1 tanesinde sıfır harici bir sayı olursa satır kalacak fakat 4ü de 0 olursa silinecek. Şimdiden teşekkür ederim. Forumda ve internette biraz araştırdım fakat tek sütun için olan var.

 

[Tevfik_Kursun]

Merhaba Arkadaşım,
Umarım işinize yarar
İyi çalışmalar

 

[serif_007]

Merhaba Arkadaşım,
Umarım işinize yarar
İyi çalışmalar

Tevfik bey çok teşekkür ederim

 

[Tevfik_Kursun]

Rica ederim arkadaşım, geri dönüş yaptığınız için ben teşekkür ederim
iyi çalışmalar

 

[Necdet]

Merhaba,
Tevfik Bey, döngüyü sondan başa doğru kurarsanız, her seferinde tekrar son satırı hesaplamanız gerekmez. Kod biraz daha hızlı çalışır.
Bir öneri olarak kabul ediniz.

 

[Tevfik_Kursun]

Çok haklısınız Necdet Hocam, teşekkürler
Saygılarımla

 

[Korhan Ayhan]

Alternatif olarak ADO kullanılabilir. Daha hızlı sonuç verecektir.

Option Explicit

Sub Delete_Zero_Rows()
    Dim My_Connection As Object, My_Recordset As Object, My_Query As String
   
    Set My_Connection = CreateObject("AdoDB.Connection")
    Set My_Recordset = CreateObject("ADODB.Recordset")
   
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
   
    My_Query = "Select * From [Sayfa1$A2:E] Where F2<>0 Or F3<>0 Or F4<>0 Or F5<>0"
   
    My_Recordset.Open My_Query, My_Connection, 3, 1
   
    Range("A2:E" & Rows.Count).ClearContents
    Range("A2").CopyFromRecordset My_Recordset
   
    My_Recordset.Close
    My_Connection.Close
   
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Korhan Ayhan]

Ek olarak işlem döngü ile yapılacaksa aşağıdaki yöntem daha hızlı sonuç verecektir.

Option Explicit

Sub Delete_Zero_Rows()
    Dim Rng As Range, Delete_Area As Range
   
    For Each Rng In Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
        If WorksheetFunction.CountIf(Rng.Offset(, 1).Resize(, 4), "<>0") = 0 Then
            If Delete_Area Is Nothing Then
                Set Delete_Area = Rng
            Else
                Set Delete_Area = Union(Delete_Area, Rng)
            End If
        End If
    Next
   
    If Not Delete_Area Is Nothing Then
        Delete_Area.EntireRow.Delete
        Set Delete_Area = Nothing
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Else
        MsgBox "Silinecek satır bulunamadı!", vbExclamation
    End If
End Sub

 

[Tevfik_Kursun]

Sayın Korhan Ayhan Hocam,
İlginize çok teşekkür ederim
Saygılarımla

 

[Necdet]

Benim de katkım olsun istedim bu soru için.
Sütun sayısının önemli olmadığı, aranan değerin parametrik olması ve aranan değerin belirlenen adetten fazla olması halinde satırın silindiği
parametrik bir örnek olmasını isterim.

Dizilerle çözüme ulaşılmıştır.

Public Sub BelirlenenSatirlariSil()

Dim ar1 As Variant, _
    ar2 As Variant, _
    i   As Long, _
    j   As Long, _
    k   As Integer, _
    adt As Integer, _
    say As Integer, _
    krk As Variant, _
    sil As Long
    
krk = 0 'Aranan Değer
say = 3 'Aranan Değer Bu Değerden Fazla İse Satır Silinir

ar1 = Range("A1").CurrentRegion.Value
ReDim ar2(1 To UBound(ar1, 1), 1 To UBound(ar1, 2))

j = 0
For i = 1 To UBound(ar1, 1)
    adt = 0
    For k = 2 To UBound(ar1, 2)
        If ar1(i, k) = krk Then adt = adt + 1
    Next k
    If Not adt > say Then
        j = j + 1
        For k = LBound(ar1, 2) To UBound(ar1, 2)
            ar2(j, k) = ar1(i, k)
        Next k
    Else
        sil = sil + 1
    End If
Next i

Range("A1").CurrentRegion.ClearContents
Range("A1").Resize(j, UBound(ar1, 2)) = ar2

If sil > 0 Then
    MsgBox sil & " Adet Satır Silinmiştir...."
Else
    MsgBox "Silinecek Satır Bulunamadı..."
End If

End Sub

 

[Tevfik_Kursun]

Sayın Necdet Hocam,
İlginize çok teşekkür ederim
Saygılarımla

 

[Necdet]

Sayın Necdet Hocam,
İlginize çok teşekkür ederim
Saygılarımla

Tevfik bey, Umarım soru sahibi arkadaşımız bu kadar bilgiden sonra baya yararlanmıştır.

 

[Tevfik_Kursun]

Sayın Necdet Hocam,
Farklı çözümlerden en çok ben yararlanıyorum. Bunun için Sitedeki arkadaşlarıma minnet borçluyum. Katkıda bulunan herkese çok teşekkür ederim.
Saygılarımla

 

[Necdet]

Sadece siz mi? biz de yararlanıyoruz.
Örneğin Korhan bey'in range'li yöntemi de baya ilginç bir çözüm, ben de yararlandım.

 

[veyselemre]

Sub test()
    Dim son&, a, i&, rng As Range
    With Sheets(1)
        son = .Cells(Rows.Count, 1).End(3).Row
        a = Filter(Evaluate(Replace("(TRANSPOSE(IF(B2:B@&C2:C@&D2:D@&E2:E@ =""0000"",ROW(A2:A@),""_"")))", "@", son)), "_", False)

        If UBound(a) > -1 Then
            Set rng = .Rows(a(0))
            If UBound(a) > 0 Then
                For i = 1 To UBound(a)
                    Set rng = Union(rng, .Rows(a(i)))
                Next i
            End If
            rng.Delete
        End If

    End With
End Sub

 

[Necdet]

Veysel beye teşekkürler, değişik bir yaklaşım.
Ben de ilk mesajımda yazdığım ve iki adet kullandığım arraylı kullanımı tek diziye indirerek yaptığım şeklini de paylaşmak istedim.
Yine Kolon bağımsız olarak.

Public Sub SatSil4()

Dim arr As Variant, _
    i   As Long, _
    j   As Long, _
    ara As String, _
    kac As Integer, _
    say As Integer, _
    k   As Integer, _
    adt As Long

ara = 0
kac = 4

arr = Range("A1").CurrentRegion.Value
j = 0

For i = 1 To UBound(arr, 1)
    say = 0
    For k = LBound(arr, 2) To UBound(arr, 2)
        say = say + InStr(1, arr(i, k), ara, vbTextCompare)
    Next k
    If say < kac Then
        j = j + 1
        For k = LBound(arr, 2) To UBound(arr, 2)
            arr(j, k) = arr(i, k)
        Next k
    End If
Next i

With Range("N1")
    .ClearContents
    .Resize(j, UBound(arr, 2)) = arr
End With

End Sub

 

[Tevfik_Kursun]

Sayın Veysel Emre Hocam ve Sayın Necdet Hocam,
İlgilerinize çok teşekkür ederim
Saygılarımla