• DİKKAT

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

VBA ile En Hızlı Vlookup Yapma konusunda yardım

Estağfurullah Sn. toybuklu ne özrü ?! ;)

Sizde de hızlı bir sonuç vermesine sevindim. 28 dk. dan --> 12 sn. ye düşürdük öyle mi ? Buna içilir işte ;) :D (çay muhabbeti geçmişti arada)


Dosyayı anlamak baya zaman aldı ve dediğim gibi doğruluğunu test etmedim.
Bahsettiğiniz alanlarla ilgilenmeden bu şarta uyanları getir dedim; [Statüler$].[Barkod Statü] = [Data$].[SBU DATA_Barkod]

Sizde durum ne olacak merakıyla yanıt gelene kadar bekledim, ama şimdi çıkmam gerek.


Eğer Zeki Bey'in vakti varsa ve ilgilenebilirse sevinirim...


İyi akşamlar.
 
Bugün Yarın Zeki Bey Yada siz destek verebilirseniz sevinirim.. Burayı sürekli takip ediyorum..
 
Şöyle olacak sanırım:

Kod: 
Sub Kaşılaştır()
    Dim cn As Object, rs As Object
    Set cn = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordset")
    cn.Open "provideR=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""excel 12.0;hdr=yes"""
    [B]sorgu = "SELECT iif([Statü Özet] = '', 'Statüsüz', [Statü Özet]) as fld, [Statü], [Statü Tarihi] from [Statüler$]"[/B]
    sorgu = sorgu + "where exists(select *  from [Data$] where [Statüler$].[Barkod Statü]=[Data$].[SBU DATA_Barkod])"
    basla = Timer
    rs.Open sorgu, cn
    Sayfa2.Range("J2").CopyFromRecordset rs
    rs.Close: cn.Close
    bitir = Timer
    MsgBox "İşlem : " & vbCr & Format(bitir - basla, "Fixed") & vbCr & "saniyede bitmiştir."
End Sub
 
Random olarak baktım ancak 30-40 binde sonrasında uyuşmayan kayıtlar var ayrıca bazı kayıtlar statülerde var ancak datada boş kalmış ayrıca eşleşmeyen kayıtların ilgili satırlarına statüsüz yazmadı. kontrollerinizi rica ederim ayrıca toplamda 28 sn sürdü :)

Son olarak 85884 satıra kadar yazıyor
 
Son düzenleme:
Alternatif olarak aşağıdaki kodu denermisiniz.

Verdiğiniz linkteki dosyada yaptığım denemede;

İ7 işlemci 8 Gb ram olan laptobumda 4-5 saniye arasında işlem tamamlanıyor.

Kod: 
Option Explicit

Sub Fast_Vlookup()
    Dim Zaman As Double, Dizi As Variant, X As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Zaman = Timer
    
    Dizi = Sheets("Statüler").Range("A1").CurrentRegion.Resize(, 4).Value
    
    With CreateObject("Scripting.Dictionary")
        For X = 2 To UBound(Dizi, 1)
            .Item(Dizi(X, 1)) = Dizi(X, 4) & "#" & Dizi(X, 3) & "#" & Dizi(X, 2)
        Next
        
        Dizi = Sheets("Data").Range("A1").CurrentRegion.Resize(, 12).Value
        
        For X = 2 To UBound(Dizi, 1)
            If .Exists(Dizi(X, 1)) Then
                Dizi(X, 10) = Split(.Item(Dizi(X, 1)), "#")(0)
                Dizi(X, 11) = Split(.Item(Dizi(X, 1)), "#")(1)
                Dizi(X, 12) = Split(.Item(Dizi(X, 1)), "#")(2)
            Else
                Dizi(X, 10) = "Statüsüz"
                Dizi(X, 11) = "Statüsüz"
                Dizi(X, 12) = "Statüsüz"
            End If
        Next
    End With
    
    Sheets("Data").Range("A2:A" & Rows.Count).NumberFormat = "@"
    Sheets("Data").Range("A1").CurrentRegion.Resize(, 12) = Dizi
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00")
End Sub
 
KORHAN Bey tek kelimeyle harikasınız İ3 Makinada 8 sn sürdü . Hepinize tek tek teşekkür ederim ilgi ve alakanıza .. Makronun mantığından ve çalışmasından kısaca bahsedebilirmisiniz nasıl oldu bu kadar hızlı.. Ne değişti :)
 
Tebrikler Korhan Bey :bravo: :bravo:

Büyük dosyalarda dizilerle çalışmanın, hız yönünden ne kadar avantajlı olduğunu herkes görmüş oldu. :bravo:
Bende doğru sonuç ADO & SQL ile bile 8 sn. sürdü, üstelik benim bilgisayarımda. :shock: Anlaşılan yenisini aldıracaksınız bana. :) :hiho:
 
Son düzenleme:
Merhaba,
Arkadaşlar,süreci ilgi ve hayranlıkla takip ettim. Benim ihtiyarda bile 18 sn. de tamamlandı. Korhan bey, İzin verirseniz , döngü ile yaptığım ve kodu başlattıktan sonra bir sahil turu yapıp geldiğim eşleştirme çalışmamda kullanacağım. Esenkalın..:bravo::bravo::bravo:
 
Son düzenleme:
Murat bey,

Teşekkür ederim. Zeki beyin ve sizin ADO-SQL örneğinizden sonra benimde aklıma büyük veri yığınlarında oldukça hızlı sonuç döndüren Dizi yöntemi ve Dictionary nesnesi geldi. Aslında bu nesne ile yazılan kodlara pek aşina değilim. Bende keyifle öğreniyorum.
 
Zeki bey,

Teşekkür ederim.
 
Zeki Bey, özelden size ulaşabileceğim bir mail adresi verebilir misiniz ?
Bir konuda fikrinizi almak istiyorum.
 
Bu çalışma gerçekten benim için bir milat oldu çünkü işyerimde yeri geldi 800 bin satır çalışmlarım olmuştu ve bazı durumlarda 250-400 binlik kayıtlarda kullanıyorum bu tarz çalışmlarda vlookup at sabah sonuca bakardım :) .. sizlerin sayesinde çok güzel bir çalışma oldu ve başkalarınında çok işine yarayacaktır.

Tek kelimeyle Üstadsınız hepiniz İyiki Varsınız...

Buradaki örnekler pek çok çalışmada geliştirilerek uyarlanarak kullanılacaktır..
 
Tekrar Merhaba Sayın Hocalarım..

Hızdan konu açılmışken bir ricam daha var mümkünse. Ek dosyada biraz kayıt var bir kolonda Korhan hocamın Fast Vlookup yöntemini çalıştırmadan önce A kolonundaki barkodlara bakmasını ve mükerrer olan kayıtların yanına Mükerer yazmasını isitiyorum ancak klasik formulasyonlarla bu yine uzun süren bir süreç. Korhan hocamın yaptığı fast Vlookup gibi bunuda ışık hızında yapmamız mümkünmüdür.

Örnek dosya ektedir ancak kayıt sayısı okadar değil 100.000 ve üzeri kayıt olduğunu göz önüne almnanızı isterim..

Tek istediğim A kolonundaki barkodların yanına mükerer ise mükerer yazacak kod Am hızlı bir şekilde.

Saygılarımla..
 

Ekli dosyalar

Merhaba,

Mükerrer kayıtların tespiti için 2007 ve sonraki versiyonlarda koşullu biçimlendirme menüsünden "YİNELENEN KAYITLAR" seçeneği var. Bu işinizi görmez mi?

Ayrıca yine aynı versiyonlarda veri menüsünden "YİNELENENLERİ KALDIR" seçeneği var. Bununla da verilerinizi hızlıca yönetebilirsiniz.

Yok ben kodla çözüm istiyorum derseniz belirtin hazırlayalım.
 
Merhaba Korhan Hocam;

Ben kayıtları silmek kaldırmak istemiyorumbu sebeple remove duplicate işime yaramıyor.
Yinelenen kayıtlar ise datayı attığımda büyük satırlarda renklendirmek yada renklineri sıraya dizemek yapıyı bozacağından işimi görmüyor

Data bana baş bir yerden geliyor ve geldiği yere bunlar mükerrer demek için yanlarına not düşüp göstermek daha pratik ve yönetilebilir..

Kodlarla hızlı bir işlem yapılabilirse çok iyi olur saygılarımla..
 
Peki "mükerrer" ifadesi tüm kayıtlaramı yazılsın. Yoksa ilki hariç diğer kayıtlara mı yazılsın. Yani sonucun aşağıdaki örneklerden hangisi gibi olmasını istiyorsunuz.

Örnek;

Elma Mükerrer
Elma Mükerrer
Ayva
Elma Mükerrer

Ya da;

Elma
Elma Mükerrer
Ayva
Elma Mükerrer
 
Merhaba,

Eğer veriler sıralı ise

B2 :

Kod: 
=A2=A1

Formülünü yazıp kopyalayın.

200 bin adet veride denedim saniye bile sürmüyor.

DOĞRU olanlar mükerrer veriler.
 
Aşağıdaki kodlar ilk kayıt hariç diğerlerine "Mükerrer" ifadesini ekliyor. Bir deneyiniz. Tümüne yazması için yarın farklı bir kodlama deneyeceğim.

500.000 kayıtta işlem bende 13-14 saniye civarında tamamlanıyor.

Kod: 
Sub Fast_Duplicate_Control()
    Dim Zaman As Double, Dizi As Variant, X As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Zaman = Timer
    
    Dizi = Sheets("Sayfa1").Range("A1").CurrentRegion.Resize(, 2).Value
    Range("B:B").ClearContents
    
    With CreateObject("Scripting.Dictionary")
        For X = 2 To UBound(Dizi, 1)
            If Not .Exists(Dizi(X, 1)) Then
                .Item(Dizi(X, 1)) = Dizi(X, 1)
            Else
                Dizi(X, 2) = "Mükerrer"
            End If
        Next
    End With
    
    With Sheets("Sayfa1")
        .Range("A2:A" & Rows.Count).NumberFormat = "@"
        .Range("A1").CurrentRegion.Resize(, 2) = Dizi
        .Cells(1, 2) = "KONTROL"
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00")
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst