Soru Düşeyara Komutunu Makro Olarak Kullanma

[husocan005]

Arkadaşlar yaklaşık 1,5 milyon civarında eşleştirmek istediğim bilgi var. Bunu Makro ile nasıl yapabilirim. Kolay gelsin.

Örnek: https://dosya.pro/file/1603871096_gunlhI

 

[Erdem Akdemir]

Merhaba,

Tüm liste sayfasını sözleşme numarasına göre sıralarsanız aşağıdaki formül hızlı çalışacaktır.

=EĞER(DÜŞEYARA(A2;'Tüm Liste'!$A$2:$A$20;1;1)=A2;DÜŞEYARA(A2;'Tüm Liste'!$A$2:$B$20;2;1))

 

[muratboz06]

Deneyiniz.

Sub ArraytoDict()
    Dim timer0 As Single
    Dim kaynak As Worksheet
    Dim hedef As Worksheet
    Dim myArray() As Variant
    Dim dict As Object
    Dim i As Long
    timer0 = Timer()
    
    Set kaynak = ThisWorkbook.Worksheets("Tüm Liste")
    Set hedef = ThisWorkbook.Worksheets("İletişim Eksik Liste")
    
    myArray = kaynak.Range("A1:B" & kaynak.Cells(kaynak.Rows.Count, "A").End(xlUp).Row).Value
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(myArray, 1)
        dict(myArray(i, 1)) = myArray(i, 2)
    Next
    
    Dim cell As Range
    hedef.Select
    Range("A2:A" & hedef.Cells(hedef.Rows.Count, "A").End(xlUp).Row).Select
    For Each cell In Selection
        cell.Offset(0, 1) = dict(cell.Value)
    Next cell
    Set dict = Nothing
    Range("B2").Select
    MsgBox "İşleminiz " & Timer - timer0 & " saniyede tamamlanmıştır."
End Sub

 

[Korhan Ayhan]

Alternatif,

Bahsettiğiniz satır sayısında daha hızlı sonuç verecektir.

1 milyon satırda işlem 50 saniye civarında sürdü.

Option Explicit

Sub Fast_Vlookup_Dictionary()
    Dim S1 As Worksheet, S2 As Worksheet, Veri As Variant, X As Long, Zaman As Double
   
    Zaman = Timer
   
    Set S1 = Sheets("Tüm Liste")
    Set S2 = Sheets("İletişim Eksik Liste")
   
    With CreateObject("Scripting.Dictionary")
        Veri = S1.Range("A1").CurrentRegion.Value
       
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            .Item(Veri(X, 1)) = Veri(X, 2)
        Next
       
       
        Veri = S2.Range("A1").CurrentRegion.Value
       
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            If .Exists(Veri(X, 1)) Then
                Veri(X, 2) = .Item(Veri(X, 1))
            End If
        Next
   
        S2.Range("A1").Resize(UBound(Veri, 1), UBound(Veri, 2)) = Veri
    End With
       
    Set S1 = Nothing
    Set S2 = Nothing
       
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[Korhan Ayhan]

Bu da ADO ile çözüm;

1 milyon satırda işlem 195 saniye civarında sürdü.

Sub Fast_Vlookup_Ado()
    Dim Baglanti As Object, Kayit_Seti As Object
    Dim Sorgu As String, S1 As Worksheet, Zaman As Double
    
    Zaman = Timer
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("İletişim Eksik Liste")
      
    S1.Range("B2:B" & S1.Rows.Count).ClearContents
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""
          
    Sorgu = "Select Tablo2.[İletişim Bilgisi] From [İletişim Eksik Liste$] As Tablo1 Left Join [Tüm Liste$] As Tablo2 " & _
            "On Tablo1.[Sözleşme No] = Tablo2.[Sözleşme No]"
    
    Kayit_Seti.Open Sorgu, Baglanti, 1, 1
    
    S1.Range("B2").CopyFromRecordset Kayit_Seti
            
    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    If Baglanti.State <> 0 Then Baglanti.Close
            
    Set S1 = Nothing
    Set Baglanti = Nothing
    Set Kayit_Seti = Nothing
        
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[husocan005]

Hocalarım çok teşekkür ederim. Emeğinize sağlık

 

[tahsinanarat]

Sn. Korhan Hocam

Option Explicit

Sub Fast_Vlookup_Dictionary()
Dim S1 As Worksheet, S2 As Worksheet, Veri As Variant, X As Long, Zaman As Double

Zaman = Timer

Set S1 = Sheets("Tüm Liste")
Set S2 = Sheets("İletişim Eksik Liste")

With CreateObject("Scripting.Dictionary")
Veri = S1.Range("A1").CurrentRegion.Value

For X = LBound(Veri, 1) To UBound(Veri, 1)
.Item(Veri(X, 1)) = Veri(X, 2)
Next


Veri = S2.Range("A1").CurrentRegion.Value

For X = LBound(Veri, 1) To UBound(Veri, 1)
If .Exists(Veri(X, 1)) Then
Veri(X, 2) = .Item(Veri(X, 1))
End If
Next

S2.Range("A1").Resize(UBound(Veri, 1), UBound(Veri, 2)) = Veri
End With

Set S1 = Nothing
Set S2 = Nothing

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

Yukarıdaki kod ile çok hızlı bir şekilde sonuç alabiliyoruz öncelikle elinize sağlık, bu kod ile eğer birden fazla sutun getirmek istersek nasıl bir değişiklik yapmalıyız, birde A sutununda eğer boş hücre olursa oraya kadar olan karşılıkları getiriyor, sanrakileri getirmiyor, yani kod bura çalışmayı durduruyor. Teşekkürler.

 

[Korhan Ayhan]

Örnek dosya eklerseniz yöntem önerisinde bulunabilirim.