Silinecek Listesindekileri Kaynak Listeden bul sil

[tahsinanarat]

Option Explicit

Sub BUL_SİL()
    Dim S1 As Worksheet, S2 As Worksheet, X As Long, SAY As Long, Y As Long

    Set S1 = Sheets("Kaynak")
    Set S2 = Sheets("Silinecek Listesi")
    
    Application.ScreenUpdating = False

    For X = 1 To S2.Range("A65536").End(3).Row
        SAY = WorksheetFunction.CountIf(S1.Columns(3), S2.Cells(X, 1))
        If SAY > 0 Then
            For Y = 1 To SAY
                S1.Columns(3).Find(S2.Cells(X, 1)).EntireRow.Delete
            Next
        End If
    Next
    Set S1 = Nothing
    Set S2 = Nothing

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Yukarıdaki kod ile Kaynak sayfamdaki datalardan Silinecek Listesi adlı sekmedeki listede yazılı dataları A sutunundaki sicile göre bulup sildirebiliyorum.

Kaynak Sayfam yaklaşık 10000 satır, silinecek listesi ise 3000 satır civarında, bu kod ile silme işlemi biraz uzun sürüyor.
Silme işlemini hızlandırmak adına başka altarnatifler arıyorum. Teşekkürler.

 

[YUSUF44]

Daha hızlı çözümler de vardır mutlaka ama en azından iç içe iki döngü yerine tersten çalışan tek döngüyle de bu işlem olur.

Option Explicit

Sub BUL_SİL()
    Dim S1 As Worksheet, S2 As Worksheet, X As Long, SAY As Long, Y As Long

    Set S1 = Sheets("Kaynak")
    Set S2 = Sheets("Silinecek Listesi")
   
    Application.ScreenUpdating = False

        For X = S1.Range("A65536").End(3).Row To 1 Step -1
            If WorksheetFunction.CountIf(S2.Columns(1), S1.Cells(X, "C")) > 0 Then
                S1.Rows(X).Delete
            End If
        Next
        Set S1 = Nothing
        Set S2 = Nothing

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[tahsinanarat]

Sn. @YUSUF44 , Her ikisinide test ettim, zaman açısından bir fark olmadı, 45.35 sn. / 46.66 sn. , ilginiz için teşekkür ediyorum.

 

[Muzaffer Ali]

Alternatif

20 den fazla satırı aynı anda silmeye izin vermediği için satırlar 20'şerli siliniyor. Biraz daha zaman azaldı.
Yaklaşık 10 saniye sürüyor.

Sub BUL_SİL()
    Dim Satirlar As String
    Dim Sec As Integer
    Dim S1 As Worksheet, S2 As Worksheet, X As Long, SAY As Long, Y As Long

    Set S1 = Sheets("Kaynak")
    Set S2 = Sheets("Silinecek Listesi")
  
    Application.ScreenUpdating = False
    For X = S1.Range("A65536").End(3).Row To 1 Step -1
        If WorksheetFunction.CountIf(S2.Columns(1), S1.Cells(X, "C")) > 0 Then
            If Satirlar = "" Then
                Satirlar = Rows(X).Address
            Else
                Satirlar = Satirlar & "," & Rows(X).Address
            End If
            Sec = Sec + 1
            If Sec = 20 Then
                S1.Range(Satirlar).EntireRow.Delete
                Sec = 0
                Satirlar = ""
            End If
            
        End If
    Next
    If Sec > 0 Then
        S1.Range(Satirlar).EntireRow.Delete
    End If
    Set S1 = Nothing
    Set S2 = Nothing
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[tahsinanarat]

Sub BUL_SİL3()
    Dim Satirlar As String
    Dim Sec As Integer
    Dim S1 As Worksheet, S2 As Worksheet, X As Long, SAY As Long, Y As Long
    Dim Zaman As Double
 
    Zaman = Timer

    Set S1 = Sheets("Rapor")
    Set S2 = Sheets("Ayrilanlar")
 
    Application.ScreenUpdating = False
    For X = S1.Range("A65536").End(3).Row To 1 Step -1
        If WorksheetFunction.CountIf(S2.Columns(1), S1.Cells(X, "A")) > 0 Then
            If Satirlar = "" Then
                Satirlar = Rows(X).Address
            Else
                Satirlar = Satirlar & "," & Rows(X).Address
            End If
            Sec = Sec + 1
            If Sec = 20 Then
                S1.Range(Satirlar).EntireRow.Delete
                Sec = 0
                Satirlar = ""
            End If
            
        End If
    Next
    If Sec > 0 Then
        S1.Range(Satirlar).EntireRow.Delete
    End If
    Set S1 = Nothing
    Set S2 = Nothing
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00") & " Saniye"
End Sub

Sn.@Muzaffer Ali[/USER] Bey, sizin kodları da iki kez test ettim, 40.48 - 41.13 saniye sürdü, bu arada Her iki sekmede siciller A sutununda bulunmakta
S1.Cells(X, "C")) > 0 Then biradaki C yi A yaparak denedim. Bilgnize.

 

[Ömer]

Merhaba,

Deneyiniz.

Sub test()
    
    Dim S1 As Worksheet, S2 As Worksheet, i As Long, c As Range, k As Range, Adr As String

    Set S1 = Sheets("Kaynak")
    Set S2 = Sheets("Silinecek Listesi")
    
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    
    For i = 1 To S2.Cells(Rows.Count, "A").End(xlUp).Row
        Set c = S1.[A:A].Find(S2.Cells(i, "A"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                If k Is Nothing Then
                    Set k = c
                Else
                    Set k = Union(k, c)
                End If
                Set c = S1.[A:A].FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    
    Next i

    If Not k Is Nothing Then k.Delete Shift:=xlUp
    
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Bitti.", vbInformation
    
End Sub

 

[Muzaffer Ali]

Sizin paylaştığınız kodlar sizde ne kadar sürüyor?

 

[tahsinanarat]

Sn. @Ömer hocam, 1.62 sn. sürmesine rağmen herhangi bir silme işlemi yapmadı. Bilginize.

 

[Ömer]

Sn. @Ömer hocam, 1.62 sn. sürmesine rağmen herhangi bir silme işlemi yapmadı. Bilginize.

Silme şartını yanlış anlamış olabilir miyim?
Silinecek Liste sayfası A sütununda 1 ile son satır arasındaki tüm değerleri, Kaynak sayfası A sütununda arar bulduklarını Kaynak sayfasından siler.

Örnek dosya ekleyerek yapmak istediğinizi açıklarsanız daha net anlaşılacaktır.

 

[Muzaffer Ali]

İlk üç kodu birkaç kez denedim
Sizin kodlarınız 20-25 saniye arası
Sayın Yusuf'un 15-20 saniye arası
Benim kodlarım 6-10 saniye arası sürüyor.

Kodlar bilgisayarın özelliklerine göre daha fazla yada daha kısa sürede bitebilir.
Sanırım sizin bilgisayarınızın özellikleri düşük.

 

[tahsinanarat]

Sn. @Muzaffer Ali Bey, benim paylaştığım kod 45.35 sn. sürüyor, sizin kodları Pc. kapatıp yeniden başlıttığımda tekrar test yaptım, 22.99 sn. sürdü, şimde tekrar denedim 22.23 sn. sürdü .

 

[Ömer]

İlave olarak ben yukarı sürükleyerek silme yapmışım, tam satır silme için.

k.Delete Shift:=xlUp

yukarıdaki satırın yerine aşağıdaki satırı yazarak deneyiniz.

k.EntireRow.Delete

.

 

[tahsinanarat]

Silme şartını yanlış anlamış olabilir miyim?
Silinecek Liste sayfası A sütununda 1 ile son satır arasındaki tüm değerleri, Kaynak sayfası A sütununda arar bulduklarını Kaynak sayfasından siler.

Örnek dosya ekleyerek yapmak istediğinizi açıklarsanız daha net anlaşılacaktır.

Ömer hocam tam anladığınız gibi.

 

[Ömer]

Ömer hocam tam anladığınız gibi.

Deneyiniz.

 

[tahsinanarat]

Sn. @Ömer hocam orjinal dosyamda test ettim, Silinecek sayfasında A-J, Kaynak Sayfasında ise A-AH sutunlarına kadar dolu veriler mevcut, Sizin kodu çalıştırdım test sonucu 123.00 saniye sürdü. Bilginize.

Bu durumda en iyi sonucu Muzaffer Ali Beyin kodlarında 23.00 sn. ile en iyi sonucu aldım, bu kodu kallanacağım. Herkese yardımlarından dolayı çok teşekkür ediyorum.

 

[Ömer]

Sütun fazla ise, demekki şartları doğru anlamamışım. 15-20 satırlık örnek dosya ekleyerek açıklamanız daha doğru olurdu.

Probleminizin çözüldüğüne sevindim.
İyi çalışmalar.

 

[Haluk]

Aşağıdaki SQL kodu da bu iş için kullanılabilir ancak, "Silinecek Siciller" adeti öyle bahsedildiği gibi 3.000 mertebelerindeyse Excel kaldırmaz.

    strSQL = "Select * From [Rapor$] Where [Sicil] Not In (Select [Sicil] From [Ayrilanlar$])"

.

 

[tahsinanarat]

@Haluk hocam, bende şimdi Ado ile yapılabilirmi diye araştırıyordum, denemekte fayda var, kod içerisinde nasıl kullanabilirim, önceki kodların saadece sorgu satırını değiştirdim, ancak hata verdi.

 

[YUSUF44]

Daha hızlı ama biraz dolambaçlı olarak şöyle olabilir:

Asıl listenizde bir sütunda EĞERSAY formülüyle Silinecekler listesinde olup olmadığı kontrol edilir.
Bu sütuna filtre uygulanıp silinmesi gerekenler filtrelenir
Filtrelenmiş satırlar seçilip silinir.

Bu işlem manuel olarak çok hızlı yapılabiliyor.

Makro kaydetle elde ettiğim aşağıdaki makro da bu işi çok hızlı yaptı. Makroyu Ömer üstadın paylaştığı dosyadaki verileri çoğaltarak denedim. Ham haliyle paylaşıyorum, asıl dosyanıza göre makroda sadeleştirme ya da geliştirme yapılabilir:

Sub Makro1()
'
' Makro1 Makro
'

'
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "=COUNTIF('Silinecek Listesi'!R1C1:R1000C1,RC[-2])"
    Range("C1").Select
    Selection.AutoFill Destination:=Range("C1:C13536")
    ActiveSheet.Range("$A$1:$C$13536").AutoFilter Field:=3, Criteria1:="1"
    Rows("1:1").Select
    Range(Selection, Selection.End(xlDown)).Delete
End Sub

 

[veyselemre]

    strSQL = "SELECT T1.* FROM [Arsiv$] T1 " & _
             "LEFT JOIN [sil$] T2 ON T1.[SİCİL]=T2.[SİCİL] " & _
             "WHERE T2.[SİCİL] IS NULL"