Koşula bağlı satır silme

[shuker]

Merhaba üstadlar, ekte gönderdiğim dosyada 30000 satırlık bir dosyam var. bu dosya içerisinde C Sütununda Proses kodları D sütununda ise o proses kodlarına ait kart numaraları mevcut. isteğim şu ;

C sütunundaki bütün Son K.Kontrol yazan satırların D hücresine karşılık gelen kart numarasını baz alarak, D sütununda bulunan bütün o parti numaralı satırların silinmesini.

Örneğin ; 7192 nolu satırda Proses sütununda bulunan Son K.Kontrol satırının D hücresinde 2019.3658.1.1 yazıyor. ancak 7191. satır da da 2019.3658.1.1 yazıyor. yazılan makro öyle bir çalışsın ki; D sütununda bulduğu tüm Son K.Kontrol hücrelerinin D sütununda karşılık gelen parti numarasını bu sütunda arayarak bütün o parti numaralı satırı silsin.

biraz karıştı mı ne ) sorunuz olursa gün icinde sürekli forumdayim. hemen dönüs yaparim.

Dosya Eki Drive dadır.

Aralık 2019 Parti Maliyetleri - 2019.xlsb

drive.google.com

 

[shuker]

üstadlar sanırım ben elle yapmaya devam edeceğim.

 

[ASLAN7410]

Merhaba, istediğiniz böyle bişey galiba, aşağıdaki kodu bir modüle yapıştırıp çalıştırın.

Sub FiltreTemizle()
    Range("A1:EV" & Rows.Count).AutoFilter Field:=2, Criteria1:="Son K.Kontrol"
    Range("A2:EV" & Rows.Count).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
    Range("A1:EV" & Rows.Count).AutoFilter Field:=2
End Sub

 

[shuker]

Merhaba, istediğiniz böyle bişey galiba, aşağıdaki kodu bir modüle yapıştırıp çalıştırın.

Sub FiltreTemizle()
    Range("A1:EV" & Rows.Count).AutoFilter Field:=2, Criteria1:="Son K.Kontrol"
    Range("A2:EV" & Rows.Count).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
    Range("A1:EV" & Rows.Count).AutoFilter Field:=2
End Sub

Hocam bu sadece "Son K.Kontrol" satırlarını siliyor galiba.

 

[Ömer]

Merhaba,
İşlem süresi biraz uzun maalesef. Bende silme süresi: 2 dk, 25 sn sürdü.

Sub Sartli_Sil()

    Dim son As Long, i As Long, j As Range, a As Long, dizi(), k As Long
    Dim zmn, c As Range, s, d As Object, deg, b, son_y As Long, f1 As Range, f2 As Range
   
    zmn = TimeValue(Now)
   
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
    End With
   
    Set d = CreateObject("Scripting.Dictionary")
    son = Cells(Rows.Count, "B").End(xlUp).Row
    If son < 3 Then Exit Sub
    Set f1 = Range("A1:EV" & son)
    Set f2 = Range("C2:C" & son)
   
    f1.AutoFilter Field:=2, Criteria1:="Son K.Kontrol"
   
    On Error GoTo atla
    For Each j In f2.SpecialCells(xlCellTypeVisible)
        deg = j.Value
        If Not d.exists(deg) Then
            d.Add deg, Nothing
            ReDim Preserve dizi(a)
            dizi(a) = j.Value
            a = a + 1
        End If
    Next j

    f2.SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
    f1.AutoFilter
    son_y = Cells(Rows.Count, "B").End(xlUp).Row

    For i = 2 To son_y
        'If Cells(i, "B") <> "Son K.Kontrol" Then
            b = Cells(i, "C")
            s = Application.Match(b, Application.Transpose(dizi), 0)
            If Not IsError(s) Then
                If c Is Nothing Then
                    Set c = Rows(i)
                Else
                    Set c = Application.Union(c, Rows(i))
                End If
            End If
        'End If
    Next i
   
    If Not c Is Nothing Then c.Delete
   
    With Application
        .ScreenUpdating = True
        .Calculation = xlAutomatic
    End With
   
    MsgBox "Silme Tamamlandı." & vbLf & CDate(TimeValue(Now) - zmn), vbInformation
    Exit Sub
atla:
    MsgBox "Son K.Kontrol Değeri Bulunamadı", vbInformation
    f1.AutoFilter
   
End Sub

 

[Korhan Ayhan]

Alternatif;

Verinizi yedekleyip deneyiniz.

Süre olarak avantaj sağlayacaktır.

Option Explicit

Sub Kosula_Bagli_Satir_Sil()
    Dim S1 As Worksheet, Son As Long, Veri As Variant, X As Long
    Dim Dizi As Object, Say As Long, Y As Integer, Zaman As Double
    Dim Liste As Variant, Satir As Long, Sutun As Integer
    
    Zaman = Timer
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Set S1 = Sheets("Sayfa1")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:ET" & Son).Value
    
    Satir = UBound(Veri, 1)
    Sutun = UBound(Application.Transpose(Veri))
    
    ReDim Liste(1 To Satir, 1 To Sutun)
    
    For X = 1 To Satir
        If Veri(X, 2) = "Son K.Kontrol" Then
            If Not Dizi.Exists(Veri(X, 3)) Then Dizi.Add Veri(X, 3), Nothing
        End If
    Next

    For X = 1 To Satir
        If Not Dizi.Exists(Veri(X, 3)) Then
            Say = Say + 1
            ReDim Preserve Liste(1 To Satir, 1 To Sutun)
            For Y = 1 To Sutun
                Liste(Say, Y) = Veri(X, Y)
            Next
        End If
    Next
    
    S1.Range("A2:A" & S1.Rows.Count).EntireRow.ClearContents
    S1.Range("A2").Resize(Say, Sutun) = Liste
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub