Dictionary DüşeyAra Çoklu Kriter

[T0lga]

Merhaba,

Dosyamda satır sayısı 400.000 üzerinde olduğundan düşeyara, indis, kaçıncı ile yaptığım formüller dosyada herhangi bir değişiklik olduğunda çok yavaş çalışıyor.

Youtube'da karşılaştığım videodan Dictionary metodunu gördüm, dosyama inanılmaz hız kattı.

Tek sorunum bir key'e ait çoklu değer varsa sadece 1 tanesini yazdırabiliyorum.

Kodu inceleyip yardımcı olabilir misiniz ?

İstediğim durum yatay olarak tüm değerlerin yazılması - 2. resimde "Sipariş - Manuel Yapılan"

Mevcut kodu çalıştırdığımda 3. resimdeki gibi liste oluşuyor

Sub DictionaryVLookup()
'Youtube video :https://www.youtube.com/watch?v=c7RNF4GIpAk
Dim x, x2, y, y2()
Dim dict2 As Object
Dim ws As Worksheet

Set ws1 = ThisWorkbook.Sheets("Liste")
Set ws2 = ThisWorkbook.Sheets("Siparis")

Set dict2 = CreateObject("Scripting.Dictionary")

    lr = ws1.Cells(Rows.Count, "A").End(xlUp).Row
    x = ws1.Range("A2:A" & lr).Value
    x2 = ws1.Range("B2:B" & lr).Value
    For i = 1 To UBound(x, 1)
        dict2.Item(x(i, 1)) = x2(i, 1)
    Next i
    lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
    y = ws2.Range("A2:A" & lr2).Value
    ReDim y2(1 To UBound(y, 1), 1 To 1)
    For i = 1 To UBound(y, 1)
        If dict2.exists(y(i, 1)) Then
            y2(i, 1) = dict2(y(i, 1))
        Else
            y2(i, 1) = "Bulunamadi"
        End If
    Next i
    ws2.Range("D2:D" & lr2).Value = y2
    'Secim iptal edildi.
    'ws2.Range("D2:D" & lr2).Select

Set dict = Nothing

End Sub

 

[T0lga]

örnek dosya
Deneme.xlsm

 

[Korhan Ayhan]

Merhaba,

Sütunlarda bir gariplik var.

Tarih alanında "MODEL" bilgisi yer alıyor.
Model alanında ise "TARİH" bilgisi yer alıyor.

Ayrıca listenizde tarih yok. Bu bilgi neye göre raporlanıyor.

 

[T0lga]

Sütun adlarında bir karışıklık olmuş. Haklısınız.

Tarih ve Adet bilgileri başka bir formülde kullanılacak.

Buradaki amacım, "Liste" sayfasında modellere karşılık gelen "Tonaj" değerlerini "Siparis" sayfasında D sütununa modellere göre yatay olarak yazdırmak.

 

[Korhan Ayhan]

Deneyiniz.

Asıl dosyanızda deneyip süreyi bildirirseniz memnun olurum.

Option Explicit

Sub Listele()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long, Veri As Variant
    Dim Dizi As Object, X As Long, Son_Satir As Long
    Dim Sutun As Integer, Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("Liste")
    Set S2 = Sheets("Siparis")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    S2.Range("D2:XFD" & S2.Rows.Count).ClearContents
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:B" & Son).Value
    Son_Satir = UBound(Veri, 1)
    
    ReDim Liste(1 To Son_Satir, 1 To 2)
    
    For X = 1 To Son_Satir
        If Not Dizi.Exists(Veri(X, 1)) Then
            Say = Say + 1
            Dizi.Add Veri(X, 1), Say
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Veri(X, 2)
        Else
            Liste(Dizi.Item(Veri(X, 1)), 2) = Liste(Dizi.Item(Veri(X, 1)), 2) & "|" & Veri(X, 2)
        End If
    Next
    
    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
    Veri = S2.Range("A2:A" & Son).Value
    Son_Satir = UBound(Veri, 1)
    Say = 0
    
    ReDim Tonaj(1 To Son_Satir, 1 To 1)
    
    For X = 1 To Son_Satir
        If Dizi.Exists(Veri(X, 1)) Then
            Say = Say + 1
            Tonaj(Say, 1) = Liste(Dizi.Item(Veri(X, 1)), 2)
        Else
            Say = Say + 1
            Tonaj(Say, 1) = "Bulunamadı."
        End If
    Next
    
    S2.Range("D2").Resize(Say, 1) = Tonaj
    
    S2.Range("D2:D" & S2.Rows.Count).TextToColumns Destination:=S2.Range("D2"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="|", _
    FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True

    S2.Columns.AutoFit
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[T0lga]

Merhaba, listede olmayan bir değere rastgeldiginde formül bozuluyor. O yüzden 290600 satıra kadar 3.18 sn sürdü. Listede olmayan bir değer için boş birakmasi gerekirken başka modelin değerini yazıyor.

 

[T0lga]

S2 kodunda

Else
Say = say + 1
Tonaj (say, 1) = "Bulunamadı" ile listede olmayan değerleri bu şekilde atlatabiliyorum.

 

[Korhan Ayhan]

Merhaba,

"Siparis" sayfasında en alta "Model 888" yazarak denedim. Bu satırı boş bıraktı. Başka modelin değerini yazmadı.

Ayrıca kod içinde kullandığım gereksiz satırları sildim. Üstteki mesajımdan son halini deneyiniz.

 

[T0lga]

eski halinde "sipariş" sayfasında arada bir yerde "liste" sayfasında olmayan bir değer olduğunda hata veriyordu.

düzeltme için teşekkürler @Korhan Ayhan

şu an istediğimden de öte oldu , yaklaşık~400.000 satır 1.28 saniye

 

[Tevfik_Kursun]

[TR][TD]
Sayın TOlga,
Lütfen basit bir örneği sisteme koyar mısın, eski öğrenci kütüklerinde çok işe yarayabilir.
İyi çalışmalar
[/TD][/TR]

 

[T0lga]

Tevfik Bey, dosyanın son halini ekliyorum.

Deneme100220.xlsm

 

[Tevfik_Kursun]

Sayın Tolga,
Teşekkür ederim, iyi çalışmalar