• DİKKAT

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

EğerSil Makrosu

aktarmamd

aktarmamd

Katılım
29 Aralık 2013
Mesajlar
218
Excel Vers. ve Dili
Office Exel 2016
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..
 

Ekli dosyalar

Deneyiniz.

C++: 
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
 
Son düzenleme:
RBozkurt' Alıntı:
Deneyiniz.

C++: 
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
Genişletmek için tıkla ...
Ü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?
 
aktarmamd' Alıntı:
Ü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?
Genişletmek için tıkla ...

2. mesajdaki kodu tekrar deneyin.
Satır referansını I'dan A sütununa değiştirdim. Hata verecek mi.
 
C++: 
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

250881
 
RBozkurt' Alıntı:
C++: 
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
Genişletmek için tıkla ...
Ü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.
 
Kod: 
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
Kod: 
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
 
Son düzenleme:
Merhaba,

Şöyle bir alternatif sunabilirim;

Kod: 
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
 
DoğanD' Alıntı:
Merhaba,

Şöyle bir alternatif sunabilirim;

Kod: 
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
Genişletmek için tıkla ...
Merhabalar,

Bu kod zinciri "400" başlığında hata döndürdü bende..
 
veyselemre' Alıntı:
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
Genişletmek için tıkla ...
Üstad,

Bu kod 2 dk sürdü gayet başarılı.. ama bunda sayaç yok eklersek kasar mı bilemedim.. B
 
aktarmamd' Alıntı:
Merhabalar,

Bu kod zinciri "400" başlığında hata döndürdü bende..
Genişletmek için tıkla ...

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.

Kod: 
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
 
Merhaba,
Ben de bir şeyler karalamıştım.

Kod: 
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
 
Necdet' Alıntı:
Merhaba,
Ben de bir şeyler karalamıştım.

Kod: 
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
Genişletmek için tıkla ...
Üstad teşekkürler fakat kod hata veriyor
250932
 
Merhaba,
Örnek dosyanızda denemiştim ve hata almadım.
 
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.

C++: 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst