Silinecek Listesindekileri Kaynak Listeden bul sil

[Haluk]

En iyi çözüm, Veysel Beyin önerdiği "Left Join" metodu. Benim önerdiğim Subquery'e göre çok daha stabil ve inanılmaz hızlı çalışıyor.

Ekli dosyada; 11 sütun * 10.000 satır verinin içinden 3.000 satırı iptal ederek geriye kalan 11 sütun * 7.000 satırlık tabloyu yaklaşık 1,2 saniyede hazırlıyor.

.

 

[tahsinanarat]

Sn. @Haluk Hocam muhteşim bir hiz, 0,33 sn. getirdi. Çok teşekkür ediyorum.
Orjinal dosyamda Ayrılanlar Sayfasındaki başlık satırı 5.sutundan başlıyor, Bu durumda kodun neresinde bir değişiklik yapmak gerekiyor. Eğer bu mümkün değilse başlıkları 1.satıra taşıyacağım. (bu sayfada Tarih aralığına göre güncellemek için ayrı bir kod çalıştırdığımdan ilk dört satırı tirih yazmak için kullanıyordum.)
Kodtaki T1. T2 Tablo1 Tablo2 yi mi ifade ediyor.
Teşekkürler

 

[tahsinanarat]

SQL:
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"

Sorgu alanıma yapıştırıp denedim ama çalıştıramadım Hocam.

 

[Haluk]

Sorgu alanıma yapıştırıp denedim ama çalıştıramadım Hocam.

Ben Veysel Bey'in önerisini dosyaya uygularken sayfa isimlerini ve alan isimlerini dosyama göre değiştirmiştim. Sizin de buna dikkat etmeniz gerekir...

Ayrıca, o baştaki "SQL: " kısmına da gerek yok.....

.

 

[Korhan Ayhan]

Bu tarz durumlarda fiziksel olarak satır silmek yerine alternatif olarak dizi metoduda kullanılabilir. Amaç istenmeyen satırlardan kurtulmak olduğu için daha hızlı sonuç verecektir.

Haluk beyin paylaştığı örnek dosyaya göre kurguladım. Kendi dosyanıza uyarlamanız gerekir.

Option Explicit

Sub Clear_Leftovers()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, Delete_List As Variant
    Dim Process_Time As Double, Y As Long
    Dim My_Data As Variant, Count_Row As Long
    
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
    
    Process_Time = Timer
    
    Set S1 = Sheets("Kaynak")
    Set S2 = Sheets("Silinecek Listesi")
    
    Delete_List = S2.Range("A1").CurrentRegion.Value
    
    With VBA.CreateObject("Scripting.Dictionary")
        For X = LBound(Delete_List, 1) To UBound(Delete_List, 1)
            .Item(Delete_List(X, 1)) = X
        Next
        
        My_Data = S1.Range("A1").CurrentRegion.Value
        
        ReDim Clean_List(1 To UBound(My_Data, 1), 1 To UBound(My_Data, 2))
        
        For X = LBound(My_Data, 1) To UBound(My_Data, 1)
            If Not .Exists(My_Data(X, 1)) Then
                Count_Row = Count_Row + 1
                For Y = 1 To UBound(My_Data, 2)
                    Clean_List(Count_Row, Y) = My_Data(X, Y)
                Next
            End If
        Next
    End With
    
    S1.Range("A2:K" & S1.Rows.Count).ClearContents
    S1.Range("A2").Resize(Count_Row, UBound(My_Data, 2)) = Clean_List
    
    Erase Delete_List
    Erase My_Data
    Erase Clean_List
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.Calculation = -4105
    Application.ScreenUpdating = 1
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00")
End Sub

 

[Haluk]

Korhan Bey; benim 12 yıllık PC'de 21 No'lu mesajdaki dosya üzerinde sizin "Dictionary" 0,36 saniye, Veysel Bey'in "SQL-LeftJoin" 1,06 saniye sürdü.


.

 

[Korhan Ayhan]

Güzel sonuçlar...

 

[tahsinanarat]

Sn. @Korhan Ayhan Hocam, kodlarınızı gerçek dosyamda uyguladım, muhteşem bir hız 5651satır veriden 3000 satır silinecek veriyi 0,21 sn. sonuç veriyor, çok teşekkür ediyorum. Hayırlı günler diliyorum. Allah Razı olsun.

 

[assenucler]

Mesajı sildim

 

[Haluk]

Konuya ilişkin başka bir alternatif ise; Excel'deki verileri bir Access dosyasına aktarıp, orada oluşturulan bir "Procedure" ile sorgu sonucunun tekrar Excel'e aktarılmasıdır. Bu çalışmada, Veysel Beyin önerdiği "Left Join" kullanılmıştır.

Bu yöntemle, 11 sütun * 10.000 satır verinin içinden 3.000 satırı iptal ederek geriye kalan 11 sütun * 7.000 satırlık tablonun elde edilmesi 0,9 saniye sürüyor. Sonuçta verilerin saklandığı bir de Access dosyası sahibi oluyoruz....

Kullanılan kod aşağıda verilmiş olup, örnek dosya ektedir...

Sub TestQueryFromACCESS()
'   Haluk - 14/12/2022
'
    Dim adoCN As Object, RS As Object, adoCAT As Object, strConnection As String
    Dim TempDB As String, strSQL As String, strSQL2 As String
    Dim DataXL As String, i As Long, j As Integer
    Dim tStart As Double
    
    Const adExecuteNoRecords = 128
    Const adUseClient = 3
    Const adOpenForwardOnly = 0
    Const adLockReadOnly = 1
    
    tStart = Timer
    
    Sheets("Guncel_Rapor").Cells.ClearContents
    
    TempDB = ThisWorkbook.Path & Application.PathSeparator & "TempDB.accdb"
    DataXL = ThisWorkbook.FullName
    
    If Dir(TempDB) <> "" Then Kill TempDB
    
    Set adoCN = CreateObject("ADODB.Connection")
    Set adoCAT = CreateObject("ADOX.Catalog")
    Set RS = CreateObject("ADODB.Recordset")
        
    strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & TempDB
    
    adoCAT.Create strConnection
    
    adoCN.Open strConnection
    
    adoCN.Execute "Create Table [Report] ([Dummy_SICIL] Double);", Options:=adExecuteNoRecords
           
    strSQL = "Select Table1.* Into [Report] " _
           & "From [Rapor$] As Table1 " _
           & "Left Join [Ayrilanlar$] As Table2 " _
           & "On Table1.[Sicil] = Table2.[Sicil] " _
           & "In '' [Excel 12.0;Database=@DataXL@] " _
           & "Where Table2.[Sicil] Is Null"
           
    strSQL2 = "Select * From [Report] Where [Sicil] Is Not Null;"
      
    adoCN.Execute "Create Procedure PROC_REPORT As " & Replace(strSQL, "@DataXL@", DataXL), Options:=adExecuteNoRecords
    adoCN.Execute "Create Procedure RPT_FINAL_REPORT AS " & strSQL2, Options:=adExecuteNoRecords
    adoCN.Execute "Drop Table [Report]"
    adoCN.Execute "Execute PROC_REPORT", Options:=adExecuteNoRecords
    adoCN.Execute "Create Index IDX_REPORT On [Report] ([Sicil])", Options:=adExecuteNoRecords
    
    RS.CursorLocation = adUseClient
    RS.Open "Select * From RPT_FINAL_REPORT", adoCN, adOpenForwardOnly, adLockReadOnly

    For j = 0 To RS.Fields.Count - 1
       Sheets("Guncel_Rapor").Cells(1, j + 1) = RS.Fields(j).Name
    Next
    
    Sheets("Guncel_Rapor").Range("A2").CopyFromRecordset RS
    MsgBox ("İşlem tamam ...." & vbCrLf & Format(Timer - tStart, "0.00 San."))
    
    RS.Close
    adoCN.Close
    
    Set RS = Nothing
    Set adoCAT = Nothing
    Set adoCN = Nothing
End Sub

.

 

[Korhan Ayhan]

Üstadım eline sağlık...

 

[tahsinanarat]

Sn. @Haluk Hocam aynı dosyada denedim 0,34 sn. Bütün sonuçlar muhteşem, hangisini kullanacağımı şaşırdım .
Haluk hocam çok teşekkür ediyorum, sayenizde arşivimizde ufkumuzda başağı bir genişledi. Hayırlı geceler diliyorum.