• DİKKAT

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

Koşullu Satır Silmek

M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Merhaba arkadaşlar Çalışmamda V sütunundaki hücrelerde Aktif yazıyorsa o hücrenin bulunduğu satırı komple silmek istiyorum. Toplam veri sayım 8000 satırdan oluşmaktadır.
 
Sub SatırSil
For i=8000 to 2 step -1
if Range("V" &i)="Aktif" then Rows(i).Delete
Next i
End sub
 
NextLevel' Alıntı:
Sub SatırSil
For i=8000 to 2 step -1
if Range("V" &i)="Aktif" then Rows(i).Delete
Next i
End sub
Genişletmek için tıkla ...
Sayın nextlevel makro istediğim gibi çalışıyor ancak 8000 satırlık veride 10 dk dır sonuç alamadım bu makroyu hızlandırmamız mümkün mü acaba
 
Uzun sürer ama 10 dakika olmamalıydı. Arzu ediyorsanız dosyanızı paylaşın.
 
Merhaba
Alternatif olarak aşağıdaki gibi denermisiniz?
"A" sütunundan itibaren boş sütun olmadığını varsayarak
s1.Range("V1:V" & x).AutoFilter Field:=22, Criteria1:="Aktif"


Kod: 
Dim s1 As Worksheet, x As Long
Application.ScreenUpdating = False
Set s1 = Sheets(ActiveSheet.Name)
x = s1.Cells(Rows.Count, "V").End(3).Row
s1.AutoFilterMode = False
s1.Range("V1").AutoFilter
s1.Range("V1:V" & x).AutoFilter Field:=22, Criteria1:="Aktif"
s1.Range("V2:V" & x).SpecialCells(xlCellTypeVisible).Cells.EntireRow.Delete
s1.AutoFilterMode = False
Application.ScreenUpdating = True
 
PLİNT' Alıntı:
Merhaba
Alternatif olarak aşağıdaki gibi denermisiniz?
"A" sütunundan itibaren boş sütun olmadığını varsayarak
s1.Range("V1:V" & x).AutoFilter Field:=22, Criteria1:="Aktif"


Kod: 
Dim s1 As Worksheet, x As Long
Application.ScreenUpdating = False
Set s1 = Sheets(ActiveSheet.Name)
x = s1.Cells(Rows.Count, "V").End(3).Row
s1.AutoFilterMode = False
s1.Range("V1").AutoFilter
s1.Range("V1:V" & x).AutoFilter Field:=22, Criteria1:="Aktif"
s1.Range("V2:V" & x).SpecialCells(xlCellTypeVisible).Cells.EntireRow.Delete
s1.AutoFilterMode = False
Application.ScreenUpdating = True
Genişletmek için tıkla ...
Sayın Pilint deneyip dönüş sağlıycağım
 
Son düzenleme:
NextLevel' Alıntı:
Uzun sürer ama 10 dakika olmamalıydı. Arzu ediyorsanız dosyanızı paylaşın.
Genişletmek için tıkla ...
Sayın nextlevel kişisel veriler olduğu için maalesef paylaşamıyorum. Sizin yazmış olduğunuz makro 22 dakikada işlemi yarıda kesti. Toplam 1743 satır silmesi gerekirken 845 satır silip işlemi bitirdi.
 
PLİNT' Alıntı:
Alternatif olarak aşağıdaki gibi denermisiniz?
"A" sütunundan itibaren boş sütun olmadığını varsayarak
s1.Range("V1:V" & x).AutoFilter Field:=22, Criteria1:="Aktif"
Genişletmek için tıkla ...
https://www.dosyaupload.com/kuSt Örnek dosyada "Q" sütunu boş
"v" sütununuyla "a" sütunu arasında boş sütun var ise olabilir boş sütundan sonra "v" sütununa kadar sütun sayısını Field:=22 "22" yerine yazın veya
makro kaydet ile şöyle yapın,
"Aktif" kelimesini filtreleyip "V" sütununu seçin, F5 ile açılan "git" penceresinden "özel"/"yalnızca görünür hücreler" i işaretler, sağ tık ile "satır sil" i seçip, silin
makroda çıkan Field:=? kısmını düzeltirsiniz
 
Son düzenleme:
Bir de bu şekilde bir deneyiniz.
Kod: 
For Each t In Range("A1:A8000").Cells
If t.Value = "Aktif" Then
t.Rows = ""
End If
Next t
 
PLİNT' Alıntı:
Merhaba
Alternatif olarak aşağıdaki gibi denermisiniz?
"A" sütunundan itibaren boş sütun olmadığını varsayarak
s1.Range("V1:V" & x).AutoFilter Field:=22, Criteria1:="Aktif"


Kod: 
Dim s1 As Worksheet, x As Long
Application.ScreenUpdating = False
Set s1 = Sheets(ActiveSheet.Name)
x = s1.Cells(Rows.Count, "V").End(3).Row
s1.AutoFilterMode = False
s1.Range("V1").AutoFilter
s1.Range("V1:V" & x).AutoFilter Field:=22, Criteria1:="Aktif"
s1.Range("V2:V" & x).SpecialCells(xlCellTypeVisible).Cells.EntireRow.Delete
s1.AutoFilterMode = False
Application.ScreenUpdating = True
Genişletmek için tıkla ...
Sayın pilint toplam 17 dk da istenilen sonucu verdi
 
Merhaba,

Eğer tablonuzda formül içeren alan yoksa aşağıdaki yöntem oldukça hızlı sonuç verecektir.

Verilerinizin A2:V... aralığında olduğu varsayılmıştır.

Verilerinizi yedekleyerek deneyiniz.

C++: 
Option Explicit

Sub Kosullu_Satir_Sil()
    Dim Zaman As Double, Veri As Variant, X As Long, Y As Byte
    Dim Son As Long, Say As Long, Silinen_Satir_Say As Long
  
    Zaman = Timer
  
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
  
    Son = Cells(Rows.Count, 1).End(3).Row
  
    If Son <= 2 Then Son = 3
  
    Veri = Range("A2:V" & Son).Value
  
    ReDim Liste(1 To Son, 1 To 22)
  
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 22) <> "Aktif" Then
            Say = Say + 1
            For Y = 1 To 22
                Liste(Say, Y) = Veri(X, Y)
            Next
        Else
            Silinen_Satir_Say = Silinen_Satir_Say + 1
        End If
    Next
  
    If Silinen_Satir_Say > 0 Then
        Range("A2:V" & Rows.Count).ClearContents
        Range("A2").Resize(Say, 22) = Liste
      
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
        MsgBox "Tablonuzdaki V sütununda ""Aktif"" ifadesini içeren satırlar temizlenmiştir." & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
        MsgBox "Silinecek kayıt bulunamadı!", vbExclamation
    End If
End Sub
 
Korhan Ayhan' Alıntı:
Merhaba,

Eğer tablonuzda formül içeren alan yoksa aşağıdaki yöntem oldukça hızlı sonuç verecektir.

Verilerinizin A2:V... aralığında olduğu varsayılmıştır.

Verilerinizi yedekleyerek deneyiniz.

C++: 
Option Explicit

Sub Kosullu_Satir_Sil()
    Dim Zaman As Double, Veri As Variant, X As Long, Y As Byte
    Dim Son As Long, Say As Long, Silinen_Satir_Say As Long
  
    Zaman = Timer
  
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
  
    Son = Cells(Rows.Count, 1).End(3).Row
  
    If Son <= 2 Then Son = 3
  
    Veri = Range("A2:V" & Son).Value
  
    ReDim Liste(1 To Son, 1 To 22)
  
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 22) <> "Aktif" Then
            Say = Say + 1
            For Y = 1 To 22
                Liste(Say, Y) = Veri(X, Y)
            Next
        Else
            Silinen_Satir_Say = Silinen_Satir_Say + 1
        End If
    Next
  
    If Silinen_Satir_Say > 0 Then
        Range("A2:V" & Rows.Count).ClearContents
        Range("A2").Resize(Say, 22) = Liste
      
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
        MsgBox "Tablonuzdaki V sütununda ""Aktif"" ifadesini içeren satırlar temizlenmiştir." & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
        MsgBox "Silinecek kayıt bulunamadı!", vbExclamation
    End If
End Sub
Genişletmek için tıkla ...
Korhan Hocam listemde S,T ve U sütunlarında satır sonuna kadar formüller var. Makroyu denemem sonucunda makronun çok hızlı çalıştığını söyleyebilirim. Ancak son satırdaki veri koşula uymamasına rağmen onuda siliyor. Birde listemde C sütununda bulunan Bayan ve Erkek isimlerinde renklendirme var. Örneğin Erkek isimleri siyah renk, bayan isimleri Kırmızı renkte bulunmakta. İşlem sonucunda satır silmeden kaynaklı sanırım Erkek ve bayan isimlerinin renklerinde kaymalar oluyor. Yani kırmızı olması gereken siyah,siyah olması gereken kırmızı oluyor
 
Sanal verilerle doldurduğunuz 10 satırlık bir örnek dosya paylaşırsanız çözüm üretilmesi kolaylaşır.

Formül ve biçim bakımından (satır-sütun-renklendirme) dosyanıza benzer olmasına dikkat etmeniz yeterli olacaktır.
 
Korhan Ayhan' Alıntı:
Sanal verilerle doldurduğunuz 10 satırlık bir örnek dosya paylaşırsanız çözüm üretilmesi kolaylaşır.

Formül ve biçim bakımından (satır-sütun-renklendirme) dosyanıza benzer olmasına dikkat etmeniz yeterli olacaktır.
Genişletmek için tıkla ...
Korhan hocam son dolu satırı A sütunu yerine B sütunundan aldırınca(count,2) en son satırdaki veriyi silmesi sorunu çözüldü. Ancak isimlerdeki renk kayması sorunu devam ediyor halen. Formülü silmesi olayını da ben elle düzeltirim sorun değil
 

Ekli dosyalar

Bu kodu bir deneyip sonucu bildirir misiniz?

C++: 
Option Explicit

Sub Satir_Sil()
    Dim X As Long, Veri As Variant, Son As Long, Alan As Range, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
    Application.EnableEvents = 0
    
    Son = Cells(Rows.Count, 1).End(3).Row
    If Son = 1 Then Son = 2
    
    Veri = Range("V1:V" & Son).Value
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) = "Aktif" Then
            If Alan Is Nothing Then
                Set Alan = Cells(X, "V")
            Else
                Set Alan = Application.Union(Alan, Cells(X, "V"))
            End If
        End If
    Next
    
    If Not Alan Is Nothing Then
        Alan.EntireRow.Delete
        Application.EnableEvents = 1
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
        MsgBox "Silme işlemi tamamlanmıştır." & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        Application.EnableEvents = 1
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
        MsgBox "Silinecek satır bulunamadı!", vbExclamation
    End If
End Sub
 
Korhan Ayhan' Alıntı:
Bu kodu bir deneyip sonucu bildirir misiniz?

C++: 
Option Explicit

Sub Satir_Sil()
    Dim X As Long, Veri As Variant, Son As Long, Alan As Range, Zaman As Double
 
    Zaman = Timer
 
    Application.ScreenUpdating = 0
 
    Son = Cells(Rows.Count, 2).End(3).Row
    If Son = 1 Then Son = 2
 
    Veri = Range("V1:V" & Son).Value
 
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) = "Aktif" Then
            If Alan Is Nothing Then
                Set Alan = Cells(X, "V")
            Else
                Set Alan = Application.Union(Alan, Cells(X, "V"))
            End If
        End If
    Next
 
    If Not Alan Is Nothing Then
        Alan.EntireRow.Delete
        Application.ScreenUpdating = 1
        MsgBox "Silme işlemi tamamlanmıştır." & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        MsgBox "Silinecek satır bulunamadı!", vbExclamation
    End If
End Sub
Genişletmek için tıkla ...
Korhan Hocam istenilen sonucu 15 dk verdi. İsim renkleri ve formüller istenildiği gibiydi
 
Dosyanızda çok fazla mı formül var. Dosyanızın boyutu nedir?
 
Sayfanın boyutu 7.57 mb. Ayrıca S,T ve U sütunlarında satır sonuna kadar formül var.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst