EğerSil Makrosu

[aktarmamd]

Merhabalar,

Ek te örnek ilettiğim dosyada belirli sütun aralıklarında "eğer satır boyunca değer sıfır ise o satırı olduğu gibi silebilecek" bir makro türetemedim destek olana şimdiden teşekkürler..

 

[RBozkurt]

Deneyiniz.

Sub SıfırSil()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long, j As Long
    Dim allZeros As Boolean
   
    Set ws = ThisWorkbook.Sheets("Sayfa1")
   
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
   
    For i = lastRow To 1 Step -1
        allZeros = True
        For j = 9 To 19 'I'den S'ye sütunları değiştirin
            If ws.Cells(i, j).Value <> 0 Then
                allZeros = False
                Exit For
            End If
        Next j
        If allZeros Then
            ws.Rows(i).Delete
        End If
    Next i
End Sub

 

[aktarmamd]

Deneyiniz.

Sub SıfırSil()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long, j As Long
    Dim allZeros As Boolean
   
    Set ws = ThisWorkbook.Sheets("Sayfa1")
   
    lastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
   
    For i = lastRow To 1 Step -1
        allZeros = True
        For j = 9 To 19 'I'den S'ye sütunları değiştirin
            If ws.Cells(i, j).Value <> 0 Then
                allZeros = False
                Exit For
            End If
        Next j
        If allZeros Then
            ws.Rows(i).Delete
        End If
    Next i
End Sub

Üstad Selamlar,

Öncelikle emeğine sağlık
Kısa tabloda işe yaradı ama yaklaşık 70 bin satırdan oluşan bir datada patladı maalesef, bunu çözebilirmiyiz birde kaç satır silmişiz bunu saydırıp uyarı olarak gösterebilirmiyiz?

 

[RBozkurt]

Üstad Selamlar,

Öncelikle emeğine sağlık
Kısa tabloda işe yaradı ama yaklaşık 70 bin satırdan oluşan bir datada patladı maalesef, bunu çözebilirmiyiz birde kaç satır silmişiz bunu saydırıp uyarı olarak gösterebilirmiyiz?

2. mesajdaki kodu tekrar deneyin.
Satır referansını I'dan A sütununa değiştirdim. Hata verecek mi.

 

[RBozkurt]

Sub SatırSilSayaçlı()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long, j As Long
    Dim allZeros As Boolean
    Dim deletedRowsCount As Long
   
    deletedRowsCount = 0
   
    Set ws = ThisWorkbook.Sheets("Sayfa1")
   
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
   
    For i = lastRow To 1 Step -1
        allZeros = True
        For j = 9 To 19 ' I'den S'ye sütunları değiştirin
            If ws.Cells(i, j).Value <> 0 Then
                allZeros = False
                Exit For
            End If
        Next j
        If allZeros Then
            ws.Rows(i).Delete
            deletedRowsCount = deletedRowsCount + 1
        End If
    Next i
   
    MsgBox deletedRowsCount & " satır silindi.", vbInformation, "Silme İşlemi Tamamlandı"
End Sub

 

[aktarmamd]

Sub SatırSilSayaçlı()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long, j As Long
    Dim allZeros As Boolean
    Dim deletedRowsCount As Long
  
    deletedRowsCount = 0
  
    Set ws = ThisWorkbook.Sheets("Sayfa1")
  
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
  
    For i = lastRow To 1 Step -1
        allZeros = True
        For j = 9 To 19 ' I'den S'ye sütunları değiştirin
            If ws.Cells(i, j).Value <> 0 Then
                allZeros = False
                Exit For
            End If
        Next j
        If allZeros Then
            ws.Rows(i).Delete
            deletedRowsCount = deletedRowsCount + 1
        End If
    Next i
  
    MsgBox deletedRowsCount & " satır silindi.", vbInformation, "Silme İşlemi Tamamlandı"
End Sub

Ekli dosyayı görüntüle 250881

Üstad, kod çalıştı fakat 9 dk sürdü işlem, bu kısaltılabilirmi bilemedim.. Ama emeğine sağlık.. teşekkür ettim.

 

[veyselemre]

Sub test()
    Dim rng, crtRng
    With Sheets("Sayfa1")
        Set rng = .Range("A1:T" & .Cells(Rows.Count, 1).End(3).Row)
        Set crtRng = Range("V1:V2")
        crtRng.Cells(2).Formula = "=COUNTIF(I2:S2,""<>0"")=0"
        rng.AdvancedFilter 1, crtRng
        rng.Offset(1).Delete shift:=xlUp
        .ShowAllData
        crtRng.ClearContents
    End With
End Sub

Sub test()
    Dim rng, son&
    With Sheets("Sayfa1")
        son = .Cells(Rows.Count, 1).End(3).Row
        .Range("U1").Value = 1
        .Range("U1:U" & son).DataSeries
        Set rng = .Range("A1:U" & son)
        .Range("V2").Formula = "=COUNTIF(I2:S2,""<>0"")=0"
        rng.AdvancedFilter 1, .Range("V1:V2")
        rng.Offset(1).ClearContents
        .ShowAllData
        rng.Sort rng.Cells(17), , , , , , , xlYes
        .Range("U:V").ClearContents
    End With
End Sub

 

[DoğanD]

Merhaba,

Şöyle bir alternatif sunabilirim;

Sub Sill()
Dim i, ss, sifir As Long
ss = Range("A" & Rows.Count).End(xlUp).Row
Range("U2").FormulaR1C1 = "=SUM(RC[-12]:RC[-2])"
Range("U2").AutoFill Range("U2:U" & ss)
    Columns("U:U").Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Add2 Key:=Range( _
        "U2:U" & ss), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sayfa1").Sort
        .SetRange Range("A2:U" & ss)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
sifir = WorksheetFunction.CountIf(Range("U:U"), 0) + 1
Rows("2:" & sifir).Delete Shift:=xlUp
End Sub

 

[aktarmamd]

Merhaba,

Şöyle bir alternatif sunabilirim;

Sub Sill()
Dim i, ss, sifir As Long
ss = Range("A" & Rows.Count).End(xlUp).Row
Range("U2").FormulaR1C1 = "=SUM(RC[-12]:RC[-2])"
Range("U2").AutoFill Range("U2:U" & ss)
    Columns("U:U").Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Add2 Key:=Range( _
        "U2:U" & ss), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sayfa1").Sort
        .SetRange Range("A2:U" & ss)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
sifir = WorksheetFunction.CountIf(Range("U:U"), 0) + 1
Rows("2:" & sifir).Delete Shift:=xlUp
End Sub

Merhabalar,

Bu kod zinciri "400" başlığında hata döndürdü bende..

 

[aktarmamd]

Sub test() Dim rng, crtRng With Sheets("Sayfa1") Set rng = .Range("A1:T" & .Cells(Rows.Count, 1).End(3).Row) Set crtRng = Range("V1:V2") crtRng.Cells(2).Formula = "=COUNTIF(I2:S2,""<>0"")=0" rng.AdvancedFilter 1, crtRng rng.Offset(1).Delete shift:=xlUp .ShowAllData crtRng.ClearContents End With End Sub

Üstad,

Bu kod 2 dk sürdü gayet başarılı.. ama bunda sayaç yok eklersek kasar mı bilemedim.. B

 

[DoğanD]

Merhabalar,

Bu kod zinciri "400" başlığında hata döndürdü bende..

Aşağıdaki kodu deneyebilir misiniz? Aslında ilki de hata vermiyordu bende fakat birkaç ekleme yaptım aşağıdaki kodda. 120B satır için 2-3 sn. gibi bir sürede çalışıyor. U ve V sütunlarını yardımcı sütun olarak kullanıyor. Eğer oralarda veriniz varsa revize etmelisiniz kodu. Ayrıca satır toplamına göre hesaplama yaptığı için verilerinizin içinde negatif değer varsa hatalı sonuç verebilir.

Sub Sill()
Dim i, ss, sifir As Long
ss = Range("A" & Rows.Count).End(xlUp).Row
    Range("v2").Select
    ActiveCell.FormulaR1C1 = "=R[-1]C+1"
Range("U2").FormulaR1C1 = "=SUM(RC[-12]:RC[-2])"
Range("U2:V2").AutoFill Range("U2:V" & ss)
    Columns("U:V").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Add2 Key:=Range( _
        "U2:U" & ss), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sayfa1").Sort
        .SetRange Range("A2:V" & ss)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
sifir = WorksheetFunction.CountIf(Range("U:U"), 0) + 1
Rows("2:" & sifir).Delete Shift:=xlUp
   ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Add2 Key:=Range( _
        "V2:V" & ss), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sayfa1").Sort
        .SetRange Range("A2:V" & ss)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("U:V").ClearContents
MsgBox sifir - 1 & " Adet Satır Silindi", vbInformation
End Sub

 

[Necdet]

Merhaba,
Ben de bir şeyler karalamıştım.

Sub Sil()

Dim arr As Variant
Dim i   As Long
Dim j   As Long
Dim k   As Integer
Dim drm As Boolean
Dim rng As Range
Dim adt As Long

Application.ScreenUpdating = False
k = Range("A1").End(xlToRight).Column + 1
Cells(1, k) = "x"
Set rng = Range("A1").CurrentRegion

rng.Columns(rng.Columns.Count).FormulaR1C1 = "=SUM(RC[-12]:RC[-2])>0"
rng(1, rng.Columns.Count) = True
rng.Sort Key1:=rng.Columns(rng.Columns.Count), order1:=xlDescending
i = 1
Do
    i = i + 1
Loop Until i = rng.Rows.Count Or rng(i, k) = False

adt = rng.Rows.Count - i + 1
rng.Rows(i & ":" & rng.Rows.Count).ClearContents
rng.Columns(rng.Columns.Count).ClearContents

MsgBox adt & " Adet Kayıt Silinmiştir...."

Application.ScreenUpdating = True

End Sub

 

[aktarmamd]

Merhaba,
Ben de bir şeyler karalamıştım.

Sub Sil()

Dim arr As Variant
Dim i   As Long
Dim j   As Long
Dim k   As Integer
Dim drm As Boolean
Dim rng As Range
Dim adt As Long

Application.ScreenUpdating = False
k = Range("A1").End(xlToRight).Column + 1
Cells(1, k) = "x"
Set rng = Range("A1").CurrentRegion

rng.Columns(rng.Columns.Count).FormulaR1C1 = "=SUM(RC[-12]:RC[-2])>0"
rng(1, rng.Columns.Count) = True
rng.Sort Key1:=rng.Columns(rng.Columns.Count), order1:=xlDescending
i = 1
Do
    i = i + 1
Loop Until i = rng.Rows.Count Or rng(i, k) = False

adt = rng.Rows.Count - i + 1
rng.Rows(i & ":" & rng.Rows.Count).ClearContents
rng.Columns(rng.Columns.Count).ClearContents

MsgBox adt & " Adet Kayıt Silinmiştir...."

Application.ScreenUpdating = True

End Sub

Üstad teşekkürler fakat kod hata veriyor

 

[Necdet]

Merhaba,
Örnek dosyanızda denemiştim ve hata almadım.

 

[Korhan Ayhan]

Merhaba,

Ben böyle yüklü verilerde fiziksel olarak satır silme işlemi yerine koşula göre verileri diziye alarak ilgili alana yeniden yazdırarak çözüm yolunu tercih ediyorum. Bu yöntem oldukça hızlı sonuç veriyor.

Aşağıdaki kod 1 milyon satırlı bir veride işlemi yaklaşık olarak 7-8 saniyede tamamlıyor.

Option Explicit

Sub Fast_Delete_Row()
    Dim X As Long, Y As Integer, My_Data As Variant
    Dim Zero_Count As Long, Delete_Data_Count As Long
    Dim No As Long, Process_Time As Double
    
    Process_Time = Timer
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
        
    My_Data = Range("A2:T" & Cells(Rows.Count, 1).End(3).Row).Value
    
    ReDim My_List(1 To UBound(My_Data, 1), 1 To UBound(My_Data, 2))
    
    For X = LBound(My_Data) To UBound(My_Data)
        Zero_Count = 0
        For Y = 9 To 19
            If My_Data(X, Y) = 0 Then Zero_Count = Zero_Count + 1
        Next
            
        If Zero_Count <> 11 Then
            No = No + 1
            For Y = 1 To UBound(My_Data, 2)
                My_List(No, Y) = My_Data(X, Y)
            Next
        Else
            Delete_Data_Count = Delete_Data_Count + 1
        End If
    Next

    With Range("A2")
        .Resize(Rows.Count - 1, UBound(My_Data, 2)).ClearContents
        .Resize(No, UBound(My_Data, 2)) = My_List
    End With
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & _
            Format(Delete_Data_Count, "#,##0") & " adet veri silinmiştir." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub

 

[aktarmamd]

End Sub

Üstad,

Ellerine sağlık hem hızlı hem hatasız, problemim çözülmüştür.