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

Haluk · 30 Eylül 2018

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,

.

gicimi · 30 Eylül 2018

Haluk Bey,

250.000 adet veri ile deniyorum.

36 sn.

Haluk · 30 Eylül 2018

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 · 30 Eylül 2018

Haluk Bey

31 sn.

Haluk · 30 Eylül 2018

@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)

.

gicimi · 30 Eylül 2018

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

Haluk · 30 Eylül 2018

Kolay gelsin ...

.

Korhan Ayhan · 1 Ekim 2018

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...

Haluk · 1 Ekim 2018

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.

.

Haluk · 1 Ekim 2018

Ayrıca, kodu çalıştırdıktan sonra bilgisayarda taskbar'ın sağ tarafındaki saati de ortya çıkartıp, izledim.......

Sonuç doğru.

.

Korhan Ayhan · 1 Ekim 2018

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

Haluk · 1 Ekim 2018

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 ...

.

Haluk · 1 Ekim 2018

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,

.

acar6783 · 8 Mart 2019

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)

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?

Haluk · 8 Mart 2019

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

.

acar6783 · 8 Mart 2019

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

.

Teşekkürler Haluk bey,

Burada kaç satıra kadar işlem yapılabiliyor?
örneğin 200.000satır girdiğimde hata veriyor?

Haluk · 8 Mart 2019

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....
.

Ziynettin · 8 Mart 2019

Merhaba,

50 satırlık gibi örnek dosya ekleyin onun üzeriden gidelim derim.

veyselemre · 8 Mart 2019

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

acar6783 · 8 Mart 2019

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....
.

Denedim fakat yaklaşık on dk dondu ama sonuç alamadım. Kapatmak zorunda kaldım

Dosya burada mevcut
https://yadi.sk/d/ZD-eRqQsIbAMmA

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

Haluk

𐱅𐰇𐰼𐰚

gicimi

Haluk

𐱅𐰇𐰼𐰚

gicimi

Haluk

𐱅𐰇𐰼𐰚

gicimi

Haluk

𐱅𐰇𐰼𐰚

Korhan Ayhan

Administrator

Haluk

𐱅𐰇𐰼𐰚

Haluk

𐱅𐰇𐰼𐰚

Korhan Ayhan

Administrator

Haluk

𐱅𐰇𐰼𐰚

Haluk

𐱅𐰇𐰼𐰚

acar6783

Haluk

𐱅𐰇𐰼𐰚

acar6783

Haluk

𐱅𐰇𐰼𐰚

Ziynettin

Destek Ekibi

veyselemre

Özel Üye

acar6783