• DİKKAT

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

Çözüldü Kapalı Sayfalardan Belirtilen Koşulla Göre Veri Aktarmak.

Tekrar merhaba;

Daha önce 70 No'lu mesajımın ekinde verilen dosyaları kaldırıp, son revize dosyayı (Start_HD2.xlsm) dosyasını ekledim. Söz konusu 70 No'lu mesajın "Not" bölümünün 4. maddesinde belirtildiği şekilde, kodların çalıştırıldığı bağımsız/harici "Start_HD.xlsm" dosyasında bu kez sorguların sonuçları için geçici sayfa/tablo kullanmak yerine direkt sonuç sayfasına veriler listelenerek hızın arttırılması amaçlandı.

@Korhan Ayhan 'ın 93 No'lu mesajında belirtildiği adetlerde veri içeren dosyalarda yaptığım denemelerde; Zeki Beyin kodlarının çalışması 46,24 saniye sürüyor, benim kodlar da 43,12 saniye sürüyor.

Bu vesileyle SQL'e ısınmamızı sağlayan Zeki Beye tekrar teşekkür ederim.

@gicimi ; revize dosyayı 200.000'er adet veri içeren dosyalarla deneyip, çalışma süresini belirtebilirseniz, sevinirim.

İyi akşamlar,

.
 
Son düzenleme:
Haluk Bey,

250.000 adet veri ile deniyorum.

36 sn.
 
Son düzenleme:
250.000'er adet veriyle 36 saniye bence çok iyi.

Zeki Beyin kodu ile kaç saniye sürüyor sizde ? Kıyaslama yapmak istiyorum da ....

.
 
@gicimi,

Bilgi için teşekkürler..... sizin veriler, benim bilgisayarımda yaptığım testlerle uyumlu. Hız performansı açısından iyi bir seviyeye gelmiş demektir.

Hem Zeki Beyin hem de benim izlediğim yöntemde; sizin veri içeren diğer dosyalara kod yazılmadığı için her ikisi de veri dosyalarının bozulma ihtimaline karşılık güvenli sayılır.

Ama yine de ben olsam Zeki Beyin dosyasını kullanırdım, onda daha başka özellikler de var çünkü. (ADM ve SDM dosyalarında mükerrer Seri No olup olmadığını kontrol ediyor)

.
 
@Haluk Bey İlginiz alakanız için teşekkürler. Kolaylıklar....
 
Kolay gelsin ...

.
 
Haluk Bey,

Ben denemelerimde "Timer" özelliğini kullandım. Bildiğim kadarıyla arada geçen süre saniye cinsinden dönüyor. Bu sebeple verdiğim test sürelerinin doğru olduğunu düşünüyorum. Yanlışsam düzeltin lütfen...
 
Korhan Bey;

Timer saniye cinsinden sonucu geri döndürür ama siz bir yerde yanlışlık yapıyorsunuz sanırım.

Benim kodlarda zaten geçen süre Now fonksiyonu kullanılarak hesaplanıp, milisaniye mertebesinde formatlandıktan sonra MsgBox ile belirtiliyor, muhtemelen görmüşünüzdür. Ben 200.000'er adet verilerin olduğu dosyaların üzerinde koda ayrıca bir de Timer ekleyerek tekrar çalıştırdım.

Şöyle bir Timer kodu kullandım.

Kod: 
    Dim StartTime As Double, EndTime As Double
    Dim timeElapsed As String
 
 
    StartTime = Timer
 
    '....
    '...
    '..

    EndTime = Timer
    timeElapsed = Format((EndTime - StartTime) / 86400, "hh:mm:ss,ms")
    MsgBox "İşlem süresi: " & timeElapsed

Hem Now fonksiyonu hem de Timer ile hesaplanan kodun çalışma süresi için ikisinin arasındaki fark 1 saniyeyi geçmiyor. Zaten Timer nesnesinin daha hassas olduğunu biliyoruz.

.
 
Son düzenleme:
Ayrıca, kodu çalıştırdıktan sonra bilgisayarda taskbar'ın sağ tarafındaki saati de ortya çıkartıp, izledim....... :LOL::LOL: Sonuç doğru.

.
 
Ben aşağıdaki gibi denemiştim...

Kod: 
    Time1 = Timer
    'Kodlarınız...
    'Kodlarınız...
    'Kodlarınız...
    Time2 = Timer

    timeElapsed = Format(Time2 - Time1, "0.00000")

    Application.ScreenUpdating = True

    MsgBox "İşlem süresi: " & timeElapsed
 
Ben şimdi sizinkini de denedim...... Sonuçlarda; üçünün de saniyeleri aynı, aralarındaki fark milisaniyelerde (1/1000 saniye).

Belki sizde göz yanılması olmuştu o sırada ...

.
 
Korhan Bey, 200.000'er adet verilerin olduğu dosyalarla ilgili koda süre hesaplamasına ilişkin 3 çeşit kodu girdim ve sonuçları aşağıdaki resimde belirtilimiştir.

İyi geceler,



.Capture.PNG
 
Son düzenleme:
Zeki Gürsoy' Alıntı:
Ekli dosyayı klasörün içine attıktan sonra çalıştırıp test edebilirsiniz.
(64 bit Excel ile daha performanslı çalışmakta)
Genişletmek için tıkla ...
Zeki bey merhaba,
Kodları sadeleştirmek gerekirse aynı çalışma kitabında farklı iki sayfayı 1. sütundaki veriye göre nasıl karşılaştırabiliriz?
 
Zeki Bey mutlaka güzel bir alternatif sunacaktır size, ama şimdilik aşağıdaki "Scripting.Dictionary" alternatifini deneyin....

1. liste Sheet1 sayfasında A1:A100 aralığında, 2. liste Sheet2 sayfasında B1:B100 aralığında ve 2.listede olup da, 1. listede olmayanlar Sheet1 sayfasında C sütununda listelenmektedir.


Kod: 
Sub Test()
    'Haluk - 08/03/2019
    'E-Posta: sa4truss@gmail.com
    '
    Dim arr1 As Variant, arr2 As Variant
    Dim Dict1 As Object, Dict2 As Object, Dict3 As Object, xItem As Variant
    Dim Sh1 As Worksheet, Sh2 As Worksheet
    
    Set Sh1 = Sheets("Sheet1")
    Set Sh2 = Sheets("Sheet2")
    
    Sh1.Range("C1:C" & Rows.Count) = Empty
    
    arr1 = Application.Transpose(Sh1.Range("A1:A100").Value2)
    arr2 = Application.Transpose(Sh2.Range("B1:B100").Value2)
    
    Set Dict1 = CreateObject("Scripting.Dictionary")
    Set Dict2 = CreateObject("Scripting.Dictionary")
    Set Dict3 = CreateObject("Scripting.Dictionary")
    
    For Each xItem In arr1
        Dict1(xItem) = True
        Dict2(xItem) = True
    Next
    
    For Each xItem In arr2
        If Dict2(xItem) = False Then Dict3(xItem) = True
    Next
    
    If Dict3.Count > 0 Then
        Sh1.Range("C1").Resize(Dict3.Count) = Application.Transpose(Dict3.Keys)
    End If
    
    Set Dict3 = Nothing
    Set Dict2 = Nothing
    Set Dict1 = Nothing
    Erase arr2
    Erase arr1
    Set Sh2 = Nothing
    Set Sh1 = Nothing
End Sub

.
 
Son düzenleme:
Haluk' Alıntı:
Zeki Bey mutlaka güzel bir alternatif sunacaktır size, ama şimdilik aşağıdaki "Scripting.Dictionary" alternatifini deneyin....

1. liste Sheet1 sayfasında A1:A100 aralığında, 2. liste Sheet2 sayfasında B1:B100 aralığında ve 2.listede olup da, 1. listede olmayanlar Sheet1 sayfasında C sütununda listelenmektedir.


Kod: 
Sub Test()
    'Haluk - 08/03/2019
    'E-Posta: sa4truss@gmail.com
    '
    Dim arr1 As Variant, arr2 As Variant
    Dim Dict1 As Object, Dict2 As Object, Dict3 As Object, xItem As Variant
    Dim Sh1 As Worksheet, Sh2 As Worksheet
  
    Set Sh1 = Sheets("Sheet1")
    Set Sh2 = Sheets("Sheet2")
  
    Sh1.Range("C1:C" & Rows.Count) = Empty
  
    arr1 = Application.Transpose(Sh1.Range("A1:A100").Value2)
    arr2 = Application.Transpose(Sh2.Range("B1:B100").Value2)
  
    Set Dict1 = CreateObject("Scripting.Dictionary")
    Set Dict2 = CreateObject("Scripting.Dictionary")
    Set Dict3 = CreateObject("Scripting.Dictionary")
  
    For Each xItem In arr1
        Dict1(xItem) = True
        Dict2(xItem) = True
    Next
  
    For Each xItem In arr2
        If Dict2(xItem) = True And Dict1.exists(xItem) Then Dict1.Remove xItem
        If Dict2(xItem) = False Then Dict3(xItem) = True
    Next
  
    If Dict3.Count > 0 Then
        Sh1.Range("C1").Resize(Dict3.Count) = Application.Transpose(Dict3.Keys)
    End If
  
    Set Dict3 = Nothing
    Set Dict2 = Nothing
    Set Dict1 = Nothing
    Erase arr2
    Erase arr1
    Set Sh2 = Nothing
    Set Sh1 = Nothing
End Sub

.
Genişletmek için tıkla ...
Teşekkürler Haluk bey,

Burada kaç satıra kadar işlem yapılabiliyor?
örneğin 200.000satır girdiğimde hata veriyor?
 
Ben o kadar fazla verinizin olacağını düşünmemiştim....

Transpose fonksiyonu 65.536 adet veriye kadar çalışır. Daha fazlası için kodda revizyon yapmak gerekir.

Aşağıdaki satırları eskisiyle değiştirip, deneyin...

Kod: 
    arr1 = Sh1.Range("A1:A200000").Value2
    arr2 = Sh2.Range("B1:B200000").Value2

Eğer, C sütunundaki sonuçlar 65.536'dan fazlaysa yine revize etmek gerekir....
.
 
Son düzenleme:
Merhaba,

50 satırlık gibi örnek dosya ekleyin onun üzeriden gidelim derim.
 
Sheet1 1.sutun ile sheet2 1.sutun karşılaştırıp , farklarını Sheet3 de 1 ve 8. sutunlara ilgili sayfalardan A:G arasını kopyalar.
Kod: 
Sub test()
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    Set s3 = Sheets("Sheet3")
    lst1 = s1.Range("a1:a" & s1.Cells(Rows.Count, 1).End(3).Row).Value2
    lst2 = s2.Range("a1:a" & s2.Cells(Rows.Count, 1).End(3).Row).Value2
    With CreateObject("Scripting.Dictionary")
        Dim w(1 To 2)
        For i = 2 To UBound(lst1)
            w(1) = i
            w(2) = 0
            ky = lst1(i, 1)
            .Item(ky) = w
        Next i
        For i = 2 To UBound(lst1)
            ky = lst2(i, 1)
            If .exists(ky) Then
                .Remove (ky)
            Else
                w(1) = 0
                w(2) = i
                .Item(ky) = w
            End If
        Next i
        itms = .items
        s3.Cells.ClearContents
        For Each itm In .items
            If itm(1) > 0 Then
                sat1 = sat1 + 1
                s1.Cells(itm(1), 1).Resize(, 6).Copy s3.Cells(sat1, 1)
            Else
                sat2 = sat2 + 1
                s2.Cells(itm(2), 1).Resize(, 6).Copy s3.Cells(sat2, 8)
            End If
        Next itm
    End With
End Sub
 
Son düzenleme:
Haluk' Alıntı:
Ben o kadar fazla verinizin olacağını düşünmemiştim....

Transpose fonksiyonu 65.536 adet veriye kadar çalışır. Daha fazlası için kodda revizyon yapmak gerekir.

Aşağıdaki satırları eskisiyle değiştirip, deneyin...

Kod: 
    arr1 = Sh1.Range("A1:A200000").Value2
    arr2 = Sh2.Range("B1:B200000").Value2

Eğer, C sütunundaki sonuçlar 65.536'dan fazlaysa yine revize etmek gerekir....
.
Genişletmek için tıkla ...
Denedim fakat yaklaşık on dk dondu ama sonuç alamadım. Kapatmak zorunda kaldım

Dosya burada mevcut
https://yadi.sk/d/ZD-eRqQsIbAMmA
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst