Soru Scripting Dictionary ile Vlookup Kullanımı

Utekiner · 24 Mayıs 2020

Arkadaşlar Merhaba,

İyi Bayramlar,

Bir sitede aşağıdaki gibi bir kod buldum. (Milyon satır veri de olsa, çok hızlı çalışan bir vlookup kodu).

Anlamaya çalıştım ancak biraz karışık geldi. Hani, bir data olur, başka yerde de karşılaştırılacak bir veri olur.

Burada karşılaştırma nerede yapılıyor, eşleşecek kayıt bulunduğunda istenilen sütunlar nerede belirtiliyor vs.

Nasıl kullanacağımı anlamak için soruyorum, rica etsem yanlarına nasıl çalıştığı ile ilgili açıklama yazabilir misiniz? yada bir örnek çalışma kitabı paylaşabilir misiniz. ?

CSS:

Dim S1 As Worksheet, s2 As Worksheet
Dim dic As Object, i As Long
Dim a(), b(), c()

t = TimeValue(Now)

Set S1 = Sheets("Data")
Set s2 = Sheets("LOOKUP")

Set dic = CreateObject("scripting.dictionary")
Set dic1 = CreateObject("scripting.dictionary")

a = S1.Range("A2:E" & S1.Cells(Rows.Count, 1).End(3).Row).Value
b = s2.Range("A2:A" & s2.Cells(Rows.Count, 1).End(3).Row).Value

   For i = 1 To UBound(b)
        dic(b(i, 1)) = b(i, 1)
    Next i

    ReDim c(1 To UBound(b), 1 To 4)

    For i = 1 To UBound(a)
        If dic.exists(a(i, 1)) Then
            dic1(a(i, 1)) = i
        End If
    Next i

    For i = 1 To UBound(b)
        For j = 1 To 4
            c(i, j) = a(dic1(b(i, 1)), j + 1)
        Next j
    Next i

s2.Range("K2:N" & s2.Cells(Rows.Count, "K").End(3).Row) = ""
s2.[K2].Resize(UBound(b), 4) = c

MsgBox CDate(TimeValue(Now) - t), vbInformation

Muzaffer Ali · 24 Mayıs 2020

Merhaba.
Aşağıdaki kod 10 milyon satırlı ve dört kolonlu bir sayfada 2 saniyede arama yapıp buluyor.

Kod:

Sub Test()
    Dim Bulunan As Range
    Dim Aranan As String
    Aranan = InputBox("Aramak istediğinizi yazınız.")
    If Aranan = "" Then Exit Sub
    Set Bulunan = Cells.Find(What:=Aranan, LookAt:=xlWhole)
    If Bulunan Is Nothing Then
        MsgBox "Aradığınız bulunamadı.", vbInformation
    Else
        MsgBox "Bulundu" & vbLf & "Kolon: " & Bulunan.Column & vbLf & "Satır: " & Bulunan.Row & vbLf & "Adres: " & Bulunan.Address
    End If
End Sub

Utekiner · 24 Mayıs 2020

@dalgalikur Bey kodlar için teşekkür ederim. Vaktiniz varsa paylaşım kodların yanlarına açıklama ekleyebilir misiniz. Genelde şirketimizdeki IT birimi paylaştığım kodlar ile raporlar gönderiyor.((Scripting Dictionary) yöntemiyle.)

Muzaffer Ali · 24 Mayıs 2020

Anlamadığınız yer olursa sormaya çekinmeyin.

Kod:

Sub Test()
    Dim Bulunan As Range
    Dim Aranan As String
    Aranan = InputBox("Aramak istediğinizi yazınız.")'aranan değişkenine mesaj ile veri atanıyor
    If Aranan = "" Then Exit Sub'Aranan değişkeni boşsa yada "Cancel" butonuna basılmışsa kodlar çalışmasın
    Set Bulunan = Cells.Find(What:=Aranan, LookAt:=xlWhole) 'What: Ne aransın? Aranan değişkenindeki değer aransın.
'LookAt:=xlWhole aranan değer hücredeki değer ile tam uyuşsun.
'Örnek Aranan "Alem" ise ve hücrede "Alemdar" yazıyorsa bulmaz.
'LookAt:=xlPart yazılırsa hücredeki değer tam uyuşmasa da bulur.
'Örnek Aranan "Alem" ise hücrede "Alemdar" yazıyorsa bulur.
    If Bulunan Is Nothing Then ' Eğer aranan bulunamadıysa yukarıda "Set Bulunan" değişkeni boş(Nothing) dir.
        MsgBox "Aradığınız bulunamadı.", vbInformation 'bulunamadı iletisi versin
    Else 'Eğer bulunduysa
'Bulundu iletisi versin
        MsgBox "Bulundu" & vbLf & "Kolon: " & Bulunan.Column & vbLf & "Satır: " & Bulunan.Row & vbLf & "Adres: " & Bulunan.Address

    End If
End Sub

Korhan Ayhan · 25 Mayıs 2020

@Utekiner,

Talep ettiğiniz açıklamaları elimden geldiğince kod satırları arasında belirttim. Umarım faydası olur.

Bana sorarsanız kodlama biraz uzatılmış gibi geldi. Biraz daha sadeleştirilmiş halini birazdan paylaşmaya çalışırım.

C++:

Private Sub CommandButton1_Click()
    Rem Makro içinde kullanılacak tanımlamalar yapılıyor.
    Dim S1 As Worksheet, S2 As Worksheet
    Dim dic As Object, dic1 As Object, i As Long
    Dim a(), b(), c()
    
    Rem Makronun çalışma süresini hesaplamak için başlama zamanı belirleniyor.
    t = TimeValue(Now)
    
    Rem Sayfalar değişkene atanıyor.
    Set S1 = Sheets("Data")
    Set S2 = Sheets("LOOKUP")
    
    Rem Verilerin hafızaya alınması için Dictionary nesneleri tanımlanıyor.
    Set dic = CreateObject("scripting.dictionary")
    Set dic1 = CreateObject("scripting.dictionary")
    
    Rem DATA sayfasındaki A-E sütun aralığındaki veriler "a" dizisine yükleniyor.
    a = S1.Range("A2:E" & S1.Cells(Rows.Count, 1).End(3).Row).Value
    
    Rem LOOKUP sayfasındaki A sütunundaki veriler "b" dizisine yükleniyor.
    b = S2.Range("A2:A" & S2.Cells(Rows.Count, 1).End(3).Row).Value
    
    Rem LOOKUP sayfasındaki A sütunundaki veriler "dic" nesnesine benzersiz yükleniyor.dizisine yükleniyor.
    For i = 1 To UBound(b)
        dic(b(i, 1)) = b(i, 1)
    Next i
    
    Rem "c" dizisi tanımlanıyor. LOOKUP sayfasındaki A sütunundaki benzersiz veri sayısı kadar satır ve 4 sütundan oluşan bir dizidir.
    ReDim c(1 To UBound(b), 1 To 4)
    
    Rem "a" dizisine yüklenen veriler döngüye alınıyor.
    Rem Döngüye alınan verilerin tem tek "dic" nesnesine yüklenen benzersiz veriler arasında varsa bu sefer "dic1" nesnesine benzersiz KEY ile yükleniyor.
    Rem Buradaki KEY "i" değeridir.
    For i = 1 To UBound(a)
        If dic.exists(a(i, 1)) Then
            dic1(a(i, 1)) = i
        End If
    Next i
    
    Rem "b" dizisine yüklenen veriler tekrar döngüye alınıyor. Bu aşamada daha önce tanımlanan "c" dizine sonuç verileri yükleniyor.
    Rem Bu döngüde "i" değeri bizim bir önceki döngüde KEY diye tanımlanan değerdir. Bu KEY değerine göre "a" dizisindeki veriler "c" dizisine yükleniyor.
    For i = 1 To UBound(b)
        For j = 1 To 4
            c(i, j) = a(dic1(b(i, 1)), j + 1)
        Next j
    Next i
    
    Rem Oluşan sonucun sayfaya aktarılması için K-N sütun aralığı temizleniyor.
    S2.Range("K2:N" & S2.Cells(Rows.Count, "K").End(3).Row) = ""
    
    Rem Oluşan sonuç dizisinin satır sayısı ve 4 sütun genişlinde yani K-N sütun aralığına yazdırılıyor.
    S2.[K2].Resize(UBound(b), 4) = c
    
    Rem Kullanıcıya işlemin ne kadar sürdüğü ile ilgili bilgilendirme mesajı veriliyor.
    MsgBox CDate(TimeValue(Now) - t), vbInformation
End Sub

Utekiner · 25 Mayıs 2020

@Korhan Ayhan Bey çok teşekkür ederim. Elinize emeğinize sağlık.

gicimi · 25 Mayıs 2020

@Korhan Ayhan Hocam Merhaba;
Sadece cevaplarda geçen ve anlayamadığınız ifadeleri, kodları, satırları bir başlık altında toplayarak yeni bir konu başlığı altında Excel Makro Eğitimi gibi konu açılarak sorabilir miyiz. Bu şekilde bir soru-cevap arşivi de oluşturmuş oluruz.

Korhan Ayhan · 25 Mayıs 2020

@Utekiner,

Sizin paylaştığınız kod benzersiz veri yapısına göre kurgulanmış.

Eğer LOOKUP sayfasında A sütununda yazılan verilerin tamamının Data sayfasında olması gerekiyor. Eğer A sütununa DENEME yazıp kodu test ederseniz hata verecektir. Dediğim gibi tamamen tablo yapısına göre hazırlanmış bir kodlamadır.

Aşağıdaki alternatif yapı ile süre biraz artıyor fakat tekrar eden ya da olmayan verilerde sorunsuz çalışmaktadır.

Paylaştığınız dosya üzerinde 11-12 saniye civarında sonuç veriyor.

C++:

Option Explicit

Sub Fast_Vlookup()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Dizi As Object, Veri As Variant, Say As Long
    Dim X As Long, Son As Long, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("Data")
    Set S2 = Sheets("LOOKUP")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:E" & Son).Value
    
    For X = LBound(Veri) To UBound(Veri)
        Dizi.Item(Veri(X, 1)) = Veri(X, 2) & "#" & Veri(X, 3) & "#" & Veri(X, 4) & "#" & Veri(X, 5)
    Next
        
    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
    Veri = S2.Range("A2:A" & Son).Value
    
    ReDim Liste(1 To UBound(Veri), 1 To 4)
    
    For X = LBound(Veri) To UBound(Veri)
        Say = Say + 1
        If Dizi.Exists(Veri(X, 1)) Then
            Liste(Say, 1) = Split(Dizi.Item(Veri(X, 1)), "#")(0)
            Liste(Say, 2) = Split(Dizi.Item(Veri(X, 1)), "#")(1)
            Liste(Say, 3) = Split(Dizi.Item(Veri(X, 1)), "#")(2)
            Liste(Say, 4) = Split(Dizi.Item(Veri(X, 1)), "#")(3)
        Else
            Liste(Say, 1) = "Yok"
            Liste(Say, 2) = "Yok"
            Liste(Say, 3) = "Yok"
            Liste(Say, 4) = "Yok"
        End If
    Next
    
    If Say > 0 Then
        S2.Range("K:N").ClearContents
        S2.Range("K2").Resize(Say, 4) = Liste
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Korhan Ayhan · 25 Mayıs 2020

@Utekiner,

Aşağıdaki yapı ise 3-4 saniye civarında sonuç veriyor.

C++:

Option Explicit

Sub Fast_Vlookup()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Veri_Tablosu As Variant, Aranan_Veri As Variant
    Dim X As Long, Son As Long, Y As Long, Say As Long
    Dim Kontrol As Boolean, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("Data")
    Set S2 = Sheets("LOOKUP")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri_Tablosu = S1.Range("A2:E" & Son).Value
    
    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
    Aranan_Veri = S2.Range("A2:A" & Son).Value
    
    ReDim Liste(1 To UBound(Aranan_Veri), 1 To 4)
    
    For X = LBound(Aranan_Veri) To UBound(Aranan_Veri)
        Kontrol = False
        For Y = LBound(Veri_Tablosu) To UBound(Veri_Tablosu)
            If Aranan_Veri(X, 1) = Veri_Tablosu(Y, 1) Then
                Say = Say + 1
                Liste(Say, 1) = Veri_Tablosu(Y, 2)
                Liste(Say, 2) = Veri_Tablosu(Y, 3)
                Liste(Say, 3) = Veri_Tablosu(Y, 4)
                Liste(Say, 4) = Veri_Tablosu(Y, 5)
                Kontrol = True
                Exit For
            End If
            If Say = UBound(Liste, 1) Then GoTo 10
        Next
        If Kontrol = False Then
            Say = Say + 1
            Liste(Say, 1) = "Yok"
            Liste(Say, 2) = "Yok"
            Liste(Say, 3) = "Yok"
            Liste(Say, 4) = "Yok"
        End If
    Next
    
10  If Say > 0 Then
        S2.Range("K:N").ClearContents
        S2.Range("K2").Resize(Say, 4) = Liste
    End If
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Korhan Ayhan · 25 Mayıs 2020

@gicimi,

Forumun yapısı zaten soru-cevap üzerine kurulmuş bir yapıdır. Dilediğiniz kadar soru sorabilirsiniz.

Soru Scripting Dictionary ile Vlookup Kullanımı

Utekiner

Muzaffer Ali

Destek Ekibi

Utekiner

Muzaffer Ali

Destek Ekibi

Korhan Ayhan

Administrator

Utekiner

gicimi

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator