SATIRDAKİ BÜTÜN DEĞERLER SIFIR VEYA BOŞ İSE SİLMEK İSTİYORUM.

[metcan3720]

Merhaba,

Öncelikle bu soru daha önce sorulmuş olabilir, kontrol etme sansım olmadı. Benim sorum şu aldığım bir raporda verilerin olduğu satırlarda tamamı sıfır ve boş olan satırların tamamını silmek istiyorum. Ekte örnek çalışmamı gönderiyorum. Yardımlarınız için şimdiden teşekkürler.

 

[ÖmerFaruk]

Arama menüsü
https://www.excel.web.tr/search/168050/?q=bo%C5%9F+sat%C4%B1rlar%C4%B1+silmek&o=date

 

[metcan3720]

Arama menüsü
https://www.excel.web.tr/search/168050/?q=bo%C5%9F+sat%C4%B1rlar%C4%B1+silmek&o=date

Teşekkür ederim, fakat ben buna ulaşamıyorum. Bu siteye ulaşılamıyor diyor.

 

[ÖmerFaruk]

Sorgu için arama sonuçları: boş satırları silmek

www.excel.web.tr

 

[Ömer]

Merhaba,

Yazmıştım boşa gitmesin.

Sub Satir_Sil()

    Dim S1 As Worksheet, i As Long, c As Range, topla As Double
    Set S1 = Sheets("Sayfa1")
    
    Application.ScreenUpdating = False
    S1.Select

    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        topla = WorksheetFunction.Sum(Range("I" & i & ":N" & i))
        If topla = 0 Then
            If c Is Nothing Then
                Set c = Rows(i)
            Else
                Set c = Application.Union(c, Rows(i))
            End If
        End If
    Next i
    
    If Not c Is Nothing Then
        c.Delete
        MsgBox "Silme Tamamladı."
    End If
    
End Sub

 

[metcan3720]

Merhaba,

Yazmıştım boşa gitmesin.

Sub Satir_Sil()

    Dim S1 As Worksheet, i As Long, c As Range, topla As Double
    Set S1 = Sheets("Sayfa1")
   
    Application.ScreenUpdating = False
    S1.Select

    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        topla = WorksheetFunction.Sum(Range("I" & i & ":N" & i))
        If topla = 0 Then
            If c Is Nothing Then
                Set c = Rows(i)
            Else
                Set c = Application.Union(c, Rows(i))
            End If
        End If
    Next i
   
    If Not c Is Nothing Then
        c.Delete
        MsgBox "Silme Tamamladı."
    End If
   
End Sub

Ömer Bey Merhaba,

Çok teşekkür ederim. Emeğinize sağlık. Şöyle bir sıkıntım var ben bunu I Sütunu ve AY sütunu arasında ve 26000 satırlı bir çalışmada yapacağım.
Makroyu ; Sütun ayarını I ve AY arası yaparak tekrar kaydedip denediğimde olmadı. satır sayısı fazla olduğu için mi yapar. Teşekkürler.

 

[Ömer]

Range("I" & i & ":N" & i)

N harfi yerine AY yazarak denediniz mi?

 

[metcan3720]

Range("I" & i & ":N" & i)

N harfi yerine AY yazarak denediniz mi?

Merhaba,
Evet "AY" olarak denediğim de aşağıdaki hata mesajını aldım. Ne demek istediğini anlamadım.

 

[Korhan Ayhan]

Deneyiniz.

Satırları silmek yerine işlemi hafızada yapıp gereksiz satırları eleyerek yeni bir tablo oluşturmak daha hızlı sonuç verecektir.

Verilerinizi yedekledikten sonra deneyiniz.

Option Explicit

Sub Sifir_ve_Bos_Olan_Satirlari_Kaldir()
    Dim Zaman As Double, Veri As Variant, Son As Long, X As Long, Say As Long
    Dim Y As Byte, Sifir_Say As Byte, Bos_Say As Byte, Silinen_Satir As Long
    
    Zaman = Timer
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    If Son <= 2 Then Son = 3
    
    Veri = Range("A2:AY" & Son).Value
    
    ReDim Liste(1 To Son, 1 To 51)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            For Y = 9 To 51
                If Veri(X, Y) = 0 Then Sifir_Say = Sifir_Say + 1
                If Veri(X, Y) = Empty Then Bos_Say = Bos_Say + 1
            Next
            If Sifir_Say <> 43 Or Bos_Say <> 43 Then
                Say = Say + 1
                For Y = 1 To 51
                    Liste(Say, Y) = Veri(X, Y)
                Next
            Else
                Silinen_Satir = Silinen_Satir + 1
            End If
            Sifir_Say = 0
            Bos_Say = 0
        End If
    Next
    
    If Silinen_Satir > 0 Then
        Range("A2:AY" & Rows.Count).ClearContents
        Range("A2").Resize(Say, 51) = Liste
        
        MsgBox "Tablonuzdaki I-AY sütun aralığındaki sıfır ve boşluk içeren satırlar temizlenmiştir." & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Tablonuzda I-AY sütun aralığının tamamında sıfır yada boşluk içeren hücre bulunamadı!", vbExclamation
    End If
End Sub

 

[metcan3720]

Deneyiniz.

Satırları silmek yerine işlemi hafızada yapıp gereksiz satırları eleyerek yeni bir tablo oluşturmak daha hızlı sonuç verecektir.

Verilerinizi yedekledikten sonra deneyiniz.

Option Explicit

Sub Sifir_ve_Bos_Olan_Satirlari_Kaldir()
    Dim Zaman As Double, Veri As Variant, Son As Long, X As Long, Say As Long
    Dim Y As Byte, Sifir_Say As Byte, Bos_Say As Byte, Silinen_Satir As Long
   
    Zaman = Timer
   
    Son = Cells(Rows.Count, 1).End(3).Row
   
    If Son <= 2 Then Son = 3
   
    Veri = Range("A2:AY" & Son).Value
   
    ReDim Liste(1 To Son, 1 To 51)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            For Y = 9 To 51
                If Veri(X, Y) = 0 Then Sifir_Say = Sifir_Say + 1
                If Veri(X, Y) = Empty Then Bos_Say = Bos_Say + 1
            Next
            If Sifir_Say <> 43 Or Bos_Say <> 43 Then
                Say = Say + 1
                For Y = 1 To 51
                    Liste(Say, Y) = Veri(X, Y)
                Next
            Else
                Silinen_Satir = Silinen_Satir + 1
            End If
            Sifir_Say = 0
            Bos_Say = 0
        End If
    Next
   
    If Silinen_Satir > 0 Then
        Range("A2:AY" & Rows.Count).ClearContents
        Range("A2").Resize(Say, 51) = Liste
       
        MsgBox "Tablonuzdaki I-AY sütun aralığındaki sıfır ve boşluk içeren satırlar temizlenmiştir." & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Tablonuzda I-AY sütun aralığının tamamında sıfır yada boşluk içeren hücre bulunamadı!", vbExclamation
    End If
End Sub

Korhan Bey Merhaba,

Emeğinize sağlık, Allah razı olsun. Çok teşekkür ederim.
İyi çalışmalar.