• 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

Murat Bey,

Aynen dediğiniz gibi sakin kafayla yeniden odaklandığımda ince detayı görebildim. Deneyip olumlu sonuç alınca da foruma ekledim.

Bende sizi tebrik ederim. Sizinde elinize sağlık, ADO ile güzel çözümler sundunuz. Bende bilgi sahibi oldum.
 
Rica ederim Korhan Bey, benim de bir faydam olabildiyse ne mutlu.


Hoşça kalın...
 
KORHAN Hocam Murat Hocam Ellerinize sağlık ... Bir süredir yoktum... Herkes için çok faydalı çalışmalar oldu sizlerle birlikte daha güzel çalışmalar dileklerim... Ellerinize sağlık.... Bu hızlı vlook sayma gibi özellikler çalışmalarımızda çok fayda sağladı....
 
Eşleştirirken Mükerrer Kayıtların Tutarlarını Toplama

Zeki Gürsoy' Alıntı:
Dosya ektedir. İki seçiminiz var:

- Query table,
- ADO

100.000 kayıttaki sonucu ben de merak ediyorum.

Kod: 
Sub test()
c = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};dbq=" & ThisWorkbook.FullName

q = "SELECT `Data$`.Barkod, `Data$`.`tarih `, `Statüler$`.`Statü 1`, `Statüler$`.`Statü 2` " & _
    "FROM `Data$` `Data$`, `Statüler$` `Statüler$` " & _
    "WHERE `Data$`.Barkod = `Statüler$`.Barkod order by 1"

Set cn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")

cn.Open c

t = Timer

rs.Open q, cn

Set sh = Worksheets.Add
sh.Name = "Rapor_" & Sheets.Count - 1

For i = 0 To rs.Fields.Count - 1
    sh.Cells(1, i + 1) = rs(i).Name
Next

sh.[a2].CopyFromRecordset rs

rs.Close
cn.Close

sh.Columns("A:D").AutoFit
sh.[a1:d1].Font.Bold = True

MsgBox "İşlem : " & vbCr & Round(Timer - t, 3) & vbCr & "saniyede bitmiştir."
End Sub
Genişletmek için tıkla ...

Merhaba,

Zeki Gürsoy Bey güzel bir kod yazmış. Ben de 120.000'e 230.000'lik iki veri setini eşleştirmek istiyorum. Zeki Bey'in vba kodunda ufak bir değişiklik yaptım ancak ihtiyacımı karşılamadı. Yardımcı olabilirseniz çok sevinirim.

Amacım:

GMD (Müşteri Numarası) ve Risk Sutununu birlikte dikkate alıp, Data ve Statüler sayfasında bu iki parametre bazındaki kayıtları eşleştirerek, eşlenenlerin tutarları toplayıp, tekil bazda ayrı bir sayfaya sekme açarak (Hedeflenen Çıktı) sayfasındaki gibi yazdırmak.

Rapor_1 sekmesini oluşturan ve üzerinde ufak bir değişiklik yaptığım Zeki Bey'in kodu, bu amaçla yazılmadığı için istediğim çıktıyı sağlayamıyor.

Ekteki dosyada hedeflediğim çıktı'yı bu ismi taşıyan sekme de gösterdim. Test amaçlı olduğu için 3-5 kayıt kullandım.

Saygılarımla,
 

Ekli dosyalar

Son düzenleme:
Yeni bir başlık açarak burayı atıf yapsaydınız iyi olacaktı öncelikle.

Hedeflenen çıktı sayfasında, gmn=11 ve risk=ars10 için, statüler sayfasındaki tablo tekile düşmez. Nedeni ise, solo isimli sütunda 05.06.2014 ve 08.06.2014 tarihlerinin tekil oluşudur.

Tarihler aynı olmalı veya hedeflenen çıktıda bulunmaması gerekir.
 
İki Sutun Arasındaki Mutabakat Farklarını Tespit Etmek İçin Tutarsal Kıyaslama

İlgilendiğiniz için teşekkür ediyorum Zeki Bey.

Forumdaki ilk mesajım olduğu için dikkat etmemişim. Şuan "İkili Eşleştirme'de Tutarları Toplatmak" isimli yeni başlık açtım.

Örnek dosyada, tekilleştirme açısından tarihlerin aynı olması gerektiğini söylemişsiniz doğrudur. Ancak ben, eşleştirme sürecinde sadece Gmn ve risk sutunlarının eşitliği halinde tutar sutunlarını toplatarak toplatılan bu tutarları birbiri ile karşılaştırıp olası farkları tespit etmek istiyorum. Şuan için tarih bilgisini önemsemiyorum. Bu yüzden ilk gelen tarih bilgisini bu kayıtlarla birlikte yazdım. Amacım ileride başka bir sutunu ilgili kayıtla birlikte listelemem gerektiğinde örnek bir sorgumun olması idi.

Asıl gayem, iki liste arasındaki tutarsal mutabakatsızlıkları belirlemek.

Data sayfasındaki GMD ve Risk sutunları ile Statüler Sayfasındaki aynı sutunları birbiri ile kıyaslayarak eşleşenlerin tutar toplamlarını almak ve tutarlar arasında oluşan farkları tespit etmek.

Sizin kodunuza SUM ilavesi yaptım ancak eksik işleç hatası aldım. Daha sonra bu eklemeyi silerek dosyayı ataçladım.

Yardımcı olabilirseniz sevinirim.

Saygılarımla,
 
Son düzenleme:
Merhaba gece gece ilgimi çekti konunuz,bende hemen benim makinede ne kadar süreceğini merak ederek dosyayı indirdim. Elimdeki cihaz 2006 senesinde aldığım ilk çift çekirdekli dizüstü bilgisayarlarından. Modifiye ederek(1.83 ghz, 3 GB Ram ve 500 GB hdd özelliklerine zamanla yükselttim) yapılan analiz sonucu "20 tane chrome üzerinden internet sayfası açık olmasına rağmen" 11.5 küsür saniye sürdü.
 
Son düzenleme:
Sanırım iyi bir sonuç elde ettiniz...
 
Korhan Ayhan' Alıntı:
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
Genişletmek için tıkla ...

Sayın hocam bu kodu 2 sütun da işlem yapacak şekilde revize edebilme şansımız varmı acaba?

Şöyle ki;
A ve B sütununda Ad Soyad şeklinde isimler var.
Bazı veriler ise Soyad Ad şeklinde yazılmışlar.
Makro bunları kontrol edecek ve mükerrer olanların ilkini bırakıp
diğerlerini "C" sütununda işaretleyecek
Buda açtığım konunun linki http://www.excel.web.tr/f48/mukerrer-tespiti-t143577.html
müsait zamanda yardımcı olabilirseniz çok sevinirm.
 
Aynı Sorundan Muzdaribim

Üstadlarım ,,
verdiğiniz kodları bendeki calısma dosyasına eklemeye calısıyorum ancak birtürlü tam istediğimi yapamadım.

sürekli rs.Open q, cn hatası verıyor , ıstedıgım yapılabılırmı yardımcı olabılırmsınız

teşekkurler
 

Ekli dosyalar

Verileri eksik taşıma

40bin satırlık veri karşılaştırması yapıyordum. Veriler cümleler halinde ve satırlar içerisinde rakamlar, metinler, özel karakterler mevcut. Boş satırlar da var. Aşağıdaki makroyu kullandığımda # değerinden önceki veriyi alıyor sonrasını almıyor. Bu sorunu nasıl çözebilirim?



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("Turkish").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("English").Range("A1").CurrentRegion.Resize (, 12).Value

For X = 2 To UBound(Dizi, 1)
If .Exists(Dizi(X, 1)) Then
Dizi(X, 3) = Split(.Item(Dizi(X, 1)), "#")(1)
'Else
'Dizi(X, 4) = ""
End If
Next
End With

Sheets("English").Range("A2:A" & Rows.Count).NumberFormat = "@"
Sheets("English").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 Ayhan' Alıntı:
Sanırım iyi bir sonuç elde ettiniz...
Genişletmek için tıkla ...
 
Dosyanızın küçük bir örneğini ekleyin inceleyelim.
 
Korhan Ayhan' Alıntı:
Dosyanızın küçük bir örneğini ekleyin inceleyelim.
Genişletmek için tıkla ...

Dosya ektedir hocam. Turkish isimli sayfadaki verileri English isimli sayfa ile karşılaştırıyor ancak eşleşen verileri taşırken # karakterinden sonrakileri siliyor. Örneğin English sayfasındaki 32 ve 67.satırlar. Ayrıca var olan verilerin üzerine yazmasını nasıl sağlayabiliriz? Eşleşmeyen eski veriler silinmesin.

Teşekkür ederim.

http://www68.zippyshare.com/v/Fz1g8ewL/file.html
 
Son düzenleme:
Eklediğiniz linki açamadım.

Farklı bir dosya barındırma sitesine yükleyip link verebilir misiniz?
 
Kusura bakmayın geç cevap veriyorum. Özel mesajınızdan konuyu hatırladım.

Burada amaç verileri birleştirirken datanızın içinde olmayan bir karakter kullanmaktır. Sizin verilerinizde "#" sembolü olduğundan ayrıştırma işleminde sorun oluyor. Bunun yerine "|" sembolünü kullanarak çözüm hazırladım. Deneyiniz.

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("Turkish").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("English").Range("A1").CurrentRegion.Resize(, 3).Value
        
        For X = 2 To UBound(Dizi, 1)
            If .Exists(Dizi(X, 1)) Then
                Dizi(X, 3) = Split(.Item(Dizi(X, 1)), "|")(1)
            Else
                Dizi(X, 3) = Dizi(X, 3)
            End If
        Next
    End With
    
    Sheets("English").Range("A2:A" & Rows.Count).NumberFormat = "@"
    Sheets("English").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
 
Merhabalar,
Aşağıdaki Kod A kolonundaki mükerrer verileri B kolonunda;
bir tanesini bıraktıktan sonra işaretliyor.
Ben ise tüm mükerrer verileri işaretlesin istiyorum
bu yönde bir revize yapılabilir mi acaba ?



Korhan Ayhan' Alıntı:
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
Genişletmek için tıkla ...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst