Soru Filtre süresini düşürmek için kod değişikliği nasıl olmalı?

[assenucler]

Değerli Dostlar,


Ev harcamalarını izlediğim ve aşağıdaki resimde görülen başlıkları içeren (A2:O1800) bir veri tabanım var.

İlk satırdaki sütunlarının her birinde (Veri / Sırala ve Filtre Uygulama /) Filtre yaptığımda ya da Filtre’yi kaldırmak istediğimde (şu an 752 kayıt için) işlem süresi 17 saniye sürmektedir.

Bu süreyi düşürmek için yardımınızı bekliyorum.

Saygılarımla,
Selim

Option Explicit
Sub Test()       
    Dim Zmn, Rng, Renk, Dizi
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    ActiveSheet.AutoFilterMode = False
    Zmn = Timer
    Set Rng = Range(Cells(2, 26), Cells(Cells(Rows.Count, 1).End(3).Row, 26))
    Range("X2:X10000").ClearContents       '
    Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(3).Row, 12)).Interior.Color = xlNone
    Rng.FormulaR1C1 = "=CONCAT(RC[-25]:RC[-14])"
    Rng.Value = Rng.Value
    Set Dizi = CreateObject("Scripting.Dictionary")
    For Each Renk In Rng
        If Renk <> "" Then
            Dizi(Renk.Value) = Dizi(Renk.Value) + 1
        End If
    Next
    For Each Renk In Rng
        If Dizi(Renk.Value) > 1 Then
            Range(Cells(Renk.Row, 1), Cells(Renk.Row, 12)).Interior.Color = vbGreen
            Cells(Renk.Row, 24) = "ÇİFT KAYIT" 
        End If
    Next
    Rng.ClearContents
    Range(Cells(1, 24), Cells(Cells(Rows.Count, 24).End(3).Row, 24)).AutoFilter Field:=1, Criteria1:="ÇİFT KAYIT"
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    MsgBox "Isleminiz tamam suresi  " & Format(Timer - Zmn, "0.00") & " Saniye"
End Sub

 

[Korhan Ayhan]

Merhaba,

Bu tarz işlemleri için örnek dosya paylaşmanız gerekir. Paylaştığınız kodda işlemi yavaşlatan durumu tespit edip ona yoğunlaşmak gerekir.

 

[assenucler]

Sayın Korhan Ayhan,

Günaydın.
Haklısınız, hazırlamaya çalışayım.

Saygılar,
Selim

 

[assenucler]

Sayın Korhan Ayhan,

Dosya ektedir.

 

[Korhan Ayhan]

Kod içinde kullanılan CONCAT fonksiyonu benim kullandığım 2016 versiyonda bulunmuyor. Sanırım Microsoft 365 sürümüne ait bir fonksiyon.

 

[assenucler]

Office 365 Ev Tr. 64 bit kullanıyorum.

 

[Korhan Ayhan]

Buradaki amacınız A-L sütun aralığında tekrar eden satırları tespit etmek mi?

 

[assenucler]

Evet, test etmek!

 

[Korhan Ayhan]

Eğer AB-AC sütunlarındaki formüller bir işe yaramıyorsa sildiğinizde makro bende yaklaşık 2 saniyede sonuç veriyor.

 

[assenucler]

Üstadım fiber İnternet bağlantı sorunu yaşıyorum. Çözüm için 48 saat süre verdiler.

Gözlerimdeki sorun nedeniyle telefonla mesaj yazmada zorlanıyorum.

İlginiz için teşekkür ederim.

 

[assenucler]

Not:
Çift kayıtların, formüller yardımıyla AE sütunu altındaki satırlarda listelenmesi çok güzel.
Hızlı bir çözüm olabilir mi?

 

[Korhan Ayhan]

Benim anlamadığım bu çalışmada çift kayıtların hiç olmaması gerekmiyor mu?

Neden bu işi en başında kayıt girişi anında engellemiyor sunuz?

 

[assenucler]

Değerli üstadım,

Gününüz aydınlık, neşeniz, sağlığınız yerinde ve kazancınız bereketli olsun.

Kayıt girişinde çift kaydı engellemek için yardımınızı rica edebilir miyim?

Saygılar,
Selim

 

[Korhan Ayhan]

Merhaba,

Forumda mükerrer ifadesi ile arama yaparsanız bolca örneğe ulaşabilirsiniz.

 

[Korhan Ayhan]

Aşağıdaki kod ile süreyi ~1 saniye civarına çekebildim. Fakat bu performansı alabilmeniz için daha önce belirttiğim gibi AB-AC sütunlarındaki formülleri temizlemelisiniz.

Option Explicit

Sub Find_Duplicate_Records()
    Dim My_Data As Variant, Last_Row As Long, X As Long, Y As Integer, Text_Join As String
    Dim My_Array As Object, Duplicate_Record_Check As Boolean, Process_Time As Double
   
    Process_Time = Timer
   
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
   
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
   
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
   
    Range("X2:X" & Rows.Count).ClearContents
   
    Last_Row = Cells(Rows.Count, 1).End(3).Row
    If Last_Row < 3 Then Last_Row = 3
   
    My_Data = Range("A2:L" & Last_Row).Value2
   
    ReDim My_List(1 To UBound(My_Data, 1), 1 To 1)
    ReDim My_Text(1 To UBound(My_Data, 2))
   
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        For Y = LBound(My_Data, 2) To UBound(My_Data, 2)
            My_Text(Y) = My_Data(X, Y)
        Next
       
        Text_Join = Join(My_Text, ",")
       
        If Not My_Array.Exists(Text_Join) Then
            My_Array.Add Text_Join, X
        Else
            Duplicate_Record_Check = True
            My_List(X, 1) = "Çift Kayıt"
            My_List(My_Array.Item(Text_Join), 1) = "Çift Kayıt"
        End If
    Next
   
    With Range("X2").Resize(UBound(My_Data, 1))
        .Value = My_List
    End With
   
    If Duplicate_Record_Check = True Then
        If ActiveSheet.AutoFilterMode Then Range("X:X").AutoFilter
        Range("X:X").AutoFilter 1, "Çift Kayıt"
    End If

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

    If Duplicate_Record_Check = True Then
        MsgBox "Duplicate records detected." & vbCr & vbCr & _
               "Processing time : " & Format(Timer - Process_Time, "0.00") & " Second"
    Else
        MsgBox "Duplicate records not found!", vbExclamation
    End If
   
    Set My_Array = Nothing
End Sub

 

[assenucler]

Değerli Üstadım,


Önerinizi dikkate alarak AB ve AC sütunlarındaki formülleri kaldırdım.

Kodunuz saniyede çift kayıtları listeledi. Size ne kadar teşekkür etsem azdır. Hakkınızı nasıl ödeyeceğimi bilmiyorum.
Sağlığınız yerinde, kazancınız bereketli, her şey gönlünüzce ve Allah'ım sizden razı olsun.

Hakkınızı helâl eder misiniz?

Sevgi ve saygılarımı sunarım.
Selim

 

[Korhan Ayhan]

Selim Bey,

Hakkım varsa helal olsun.

Ek olarak boş bir tablo hazırladım. Bu tabloda 15 sütunluk bir veri girişi alanı tanımladım. Son sütun ise mükerrerlik kontrolü için yardımcı sütun olarak kullanılmıştır.

Bu tabloda bir verinin mükerrer olabilmesi için 15 sütuna girilen verilerin tümünün aynı olması gerekiyor. Yani mükerrer kontrolü için 15 sütunun dolu olması gerekiyor.

Tabloya basit veri girişleri yaparak test edebilirsiniz. Aklıma gelen kontrolleri ekledim. Elbette eksikleri olabilir ama temel düzeyde işinizi görecektir.

 

[assenucler]

Sayın Korhan Ayhan,

Değerli üstadım, sizler yüreği ne kadar güzel ve sevgi dolu kişilersiniz. Bizlere hiç bir menfaat gözetmeden, burada yardımcı oluyorsunuz. Karşılaştığımız sorunlarda karanlıklar içindeyken, yolumuzu aydınlatan birer meşalesiniz; eğitici öğretici olarak, bıkmadan ve usanmadan bizlere destek oluyorsunuz. Sizleri seviyoruz. Rabbim de sizlerden razı olsun.

Yardımınız ve emeğiniz için bir kez daha, teşekkür eder, en içten sevgi saygılarımı sunarım.

Selim

 

[Korhan Ayhan]

Bilmukabele Selim Bey..