Soru VLookup / Düşeyara Daha hızlı kod yada alternatif

Korhan Ayhan · 4 Nisan 2022

Deneyiniz.

C++:

Option Explicit

Sub Lokasyonlari_Ayir()
    Dim S1 As Worksheet, Dizi As Object, Say As Long
    Dim Veri As Variant, Son As Long, X As Long, Zaman As Double
    Dim Baglanti As Object, Kayit_Seti As Object, Sorgu As String
    Dim Fis_No As Variant, Kontrol As Boolean, Kriter As Variant
    
    Zaman = Timer
    
    Set S1 = Sheets("Sayfa2")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
    Set Baglanti = VBA.CreateObject("AdoDb.Connection")
    Set Kayit_Seti = VBA.CreateObject("AdoDb.Recordset")
    
    With S1.Range("J2:AA" & S1.Rows.Count)
        .Clear
    End With
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    
    Veri = S1.Range("A2:H" & Son).Value
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 5) <> "" Then
            If Not Dizi.Exists(Veri(X, 5)) Then
                Dizi.Add Veri(X, 5), Array(1, X)
            Else
                Kriter = Dizi.Item(Veri(X, 5))
                Kriter(0) = Kriter(0) + 1
                Dizi.Item(Veri(X, 5)) = Kriter
            End If
        End If
    Next
    
    ReDim Liste(1 To UBound(Veri, 1), 1 To 1)
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    For Each Fis_No In Dizi.Keys
        Sorgu = "Select * From [Sayfa2$] Where F5 = '" & Fis_No & "' And (F1 Like '391%' Or F1 Like '120.02%')"
        Kayit_Seti.Open Sorgu, Baglanti, 1, 1
        If Kayit_Seti.RecordCount > 0 Then Kontrol = True
        Kayit_Seti.Close
        
        Sorgu = "Select * From [Sayfa2$] Where F5 = '" & Fis_No & "' And (F1 Like '191%' Or F1 Like '320.02%')"
        Kayit_Seti.Open Sorgu, Baglanti, 1, 1
        If Kayit_Seti.RecordCount > 0 Then Kontrol = True
        Kayit_Seti.Close
                    
        If Kontrol = True Then
            For X = Dizi.Item(Fis_No)(1) To Dizi.Item(Fis_No)(1) + Dizi.Item(Fis_No)(0) - 1
                Say = Say + 1
                Liste(Say, 1) = "Ramada"
            Next
        End If
    Next

    If Baglanti.State <> 0 Then Baglanti.Close
    
    If Say > 0 Then
        S1.Range("J2").Resize(Say) = Liste
        MsgBox "Lokasyon ayrımı yapılmıştır." & vbCrLf & vbCrLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If

    Set S1 = Nothing
    Set Dizi = Nothing
    Set Baglanti = Nothing
    Set Kayit_Seti = Nothing
End Sub

walabi · 4 Nisan 2022

Korhan Bey ,

Kodlarınızı kendi örnek dosyama ve verilerime uyguladım. Yanlış yapmadıysam tüm satırlara veri yazdırılıyor, herhangi bir ayırım yapmıyor. Bakmak isterseniz örnek dosyayı ve verileri yüklemiş oldum. Örnek olarak Fiş No sütununda 70023 nolu fişde benim belirtmiş olduğum kriterlerin hiçbiri olmamasına rağmen bu fişin satırlarına da veri yazdırılmış. Sanırım bu düzeltilebilir.

Asıl sıkıntı ise sonucun çok geç geliyor olması. Örnek dosya verileri 24 satır, bunun sonucu 10 saniyeden fazla sürüyor. 1000 satırın biraz üzerinde bir veride yanlış hatırlamıyorsam yarım saate yakın sürmüştü. Enaz 20.000 satırın üzerinde bir veride çalışacak olduğum için excel kitlenir kalır diye düşünüyorum. Çok zaruri bir işlem olmadığı için daha fazla vaktinizi almak istemiyorum. Ancak yine de incelemek isterseniz örnek dosya ve veriler ektedir.

Emeğiniz için teşekkürler, saygılar.

Korhan Ayhan · 4 Nisan 2022

Sanırım yöntemi değiştirmek gerekecek. Ben doğru ADO sorgusunu sanırım yazmayı beceremedim.

Neyse dizi yöntemiyle halletmeye çalışırım.

Son paylaştığınız dosyada Ramada yazılması gereken kayıt var mı?

walabi · 4 Nisan 2022

Korhan Ayhan' Alıntı:
Sanırım yöntemi değiştirmek gerekecek. Ben doğru ADO sorgusunu sanırım yazmayı beceremedim.

Neyse dizi yöntemiyle halletmeye çalışırım.

Son paylaştığınız dosyada Ramada yazılması gereken kayıt var mı?

Merhaba,

Evet var ancak zamanınızı almak istemem. Konuyu fazla uzattım gibi.

İyi günler,

Korhan Ayhan · 4 Nisan 2022

Konu yarım kalmasın sonuçlandırıp kapatalım.

walabi · 4 Nisan 2022

Korhan Ayhan' Alıntı:
Konu yarım kalmasın sonuçlandırıp kapatalım.

Tamamdır, teşekkürler,

Korhan Ayhan · 4 Nisan 2022

Son paylaştığınız dosyada Ramada yazması gereken kayıtları örneklendirireniz devam edebiliriz.

walabi · 4 Nisan 2022

Korhan Ayhan' Alıntı:
Son paylaştığınız dosyada Ramada yazması gereken kayıtları örneklendirireniz devam edebiliriz.

Korhan Bey merhaba, iş yoğunluğumdan dolayı şimdi cevap yazabiliyorum. Şöyle yaptım, yeni bir örnek dosya yüklüyorum. Bu dosyada hangi satırların karşısına ne yazması gerektiğini, hangi satırların boş kalması gerektiğini örneklendirmeye çalıştım. Veriler gerçek veri olmayıp yapı itibari ile aslının aynıdır. Fiş No sütunu olarak I sütununu kullanabilir misiniz. Bu sütunu ben kendim oluşturacağım.

Teşekkürler,

Korhan Ayhan · 5 Nisan 2022

Deneyiniz.

C++:

Option Explicit

Private Sub CommandButton1_Click()
    Dim S1 As Worksheet, Dizi As Object, Say As Long
    Dim Veri As Variant, Son As Long, X As Long
    Dim Fis_No As Variant, Kriter As Variant, Zaman As Double
    Dim Kontrol_A As Boolean, Kontrol_B As Boolean
    
    Zaman = Timer
    
    Set S1 = Sheets("Muavin")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
    
    With S1.Range("J2:J" & S1.Rows.Count)
        .Clear
    End With
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    
    Veri = S1.Range("A2:I" & Son).Value
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 9) <> "" Then
            If Not Dizi.Exists(Veri(X, 9)) Then
                Dizi.Add Veri(X, 9), Array(1, X, "|" & Veri(X, 1))
            Else
                Kriter = Dizi.Item(Veri(X, 9))
                Kriter(0) = Kriter(0) + 1
                Kriter(2) = Kriter(2) & ",|" & Veri(X, 1)
                Dizi.Item(Veri(X, 9)) = Kriter
            End If
        End If
    Next
    
    ReDim Liste(1 To UBound(Veri, 1), 1 To 1)
    
    For Each Fis_No In Dizi.Keys
        Kriter = Dizi.Item(Fis_No)(2)
        
        If Kriter Like "*|391*" And Kriter Like "*|120.02*" Then Kontrol_A = True
        If Kriter Like "*|191*" And Kriter Like "*|320.02*" Then Kontrol_A = True
        
        If Kriter Like "*|391*" And Kriter Like "*|120.01*" Then Kontrol_B = True
        If Kriter Like "*|191*" And Kriter Like "*|320.01*" Then Kontrol_B = True
        
        If Kontrol_A = True Then
            For X = Dizi.Item(Fis_No)(1) To Dizi.Item(Fis_No)(1) + Dizi.Item(Fis_No)(0) - 1
                Say = Say + 1
                Liste(X, 1) = "Ramada"
            Next
        End If
        
        If Kontrol_B = True Then
            For X = Dizi.Item(Fis_No)(1) To Dizi.Item(Fis_No)(1) + Dizi.Item(Fis_No)(0) - 1
                Say = Say + 1
                Liste(X, 1) = "Merkez"
            Next
        End If
        
        Kontrol_A = False
        Kontrol_B = False
    Next

    If Say > 0 Then
        S1.Range("J2").Resize(UBound(Veri, 1)) = Liste
        MsgBox "Lokasyon ayrımı yapılmıştır." & vbCrLf & vbCrLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If

    Set S1 = Nothing
    Set Dizi = Nothing
End Sub

walabi · 5 Nisan 2022

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Private Sub CommandButton1_Click()
    Dim S1 As Worksheet, Dizi As Object, Say As Long
    Dim Veri As Variant, Son As Long, X As Long
    Dim Fis_No As Variant, Kriter As Variant, Zaman As Double
    Dim Kontrol_A As Boolean, Kontrol_B As Boolean
   
    Zaman = Timer
   
    Set S1 = Sheets("Muavin")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
   
    With S1.Range("J2:J" & S1.Rows.Count)
        .Clear
    End With
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
   
    Veri = S1.Range("A2:I" & Son).Value
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 9) <> "" Then
            If Not Dizi.Exists(Veri(X, 9)) Then
                Dizi.Add Veri(X, 9), Array(1, X, "|" & Veri(X, 1))
            Else
                Kriter = Dizi.Item(Veri(X, 9))
                Kriter(0) = Kriter(0) + 1
                Kriter(2) = Kriter(2) & ",|" & Veri(X, 1)
                Dizi.Item(Veri(X, 9)) = Kriter
            End If
        End If
    Next
   
    ReDim Liste(1 To UBound(Veri, 1), 1 To 1)
   
    For Each Fis_No In Dizi.Keys
        Kriter = Dizi.Item(Fis_No)(2)
       
        If Kriter Like "*|391*" And Kriter Like "*|120.02*" Then Kontrol_A = True
        If Kriter Like "*|191*" And Kriter Like "*|320.02*" Then Kontrol_A = True
       
        If Kriter Like "*|391*" And Kriter Like "*|120.01*" Then Kontrol_B = True
        If Kriter Like "*|191*" And Kriter Like "*|320.01*" Then Kontrol_B = True
       
        If Kontrol_A = True Then
            For X = Dizi.Item(Fis_No)(1) To Dizi.Item(Fis_No)(1) + Dizi.Item(Fis_No)(0) - 1
                Say = Say + 1
                Liste(X, 1) = "Ramada"
            Next
        End If
       
        If Kontrol_B = True Then
            For X = Dizi.Item(Fis_No)(1) To Dizi.Item(Fis_No)(1) + Dizi.Item(Fis_No)(0) - 1
                Say = Say + 1
                Liste(X, 1) = "Merkez"
            Next
        End If
       
        Kontrol_A = False
        Kontrol_B = False
    Next

    If Say > 0 Then
        S1.Range("J2").Resize(UBound(Veri, 1)) = Liste
        MsgBox "Lokasyon ayrımı yapılmıştır." & vbCrLf & vbCrLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If

    Set S1 = Nothing
    Set Dizi = Nothing
End Sub

Korhan Bey teşekkürler,

Tam istediğin gibi olmuş.

walabi · 9 Nisan 2022

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Private Sub CommandButton1_Click()
    Dim S1 As Worksheet, Dizi As Object, Say As Long
    Dim Veri As Variant, Son As Long, X As Long
    Dim Fis_No As Variant, Kriter As Variant, Zaman As Double
    Dim Kontrol_A As Boolean, Kontrol_B As Boolean
   
    Zaman = Timer
   
    Set S1 = Sheets("Muavin")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
   
    With S1.Range("J2:J" & S1.Rows.Count)
        .Clear
    End With
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
   
    Veri = S1.Range("A2:I" & Son).Value
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 9) <> "" Then
            If Not Dizi.Exists(Veri(X, 9)) Then
                Dizi.Add Veri(X, 9), Array(1, X, "|" & Veri(X, 1))
            Else
                Kriter = Dizi.Item(Veri(X, 9))
                Kriter(0) = Kriter(0) + 1
                Kriter(2) = Kriter(2) & ",|" & Veri(X, 1)
                Dizi.Item(Veri(X, 9)) = Kriter
            End If
        End If
    Next
   
    ReDim Liste(1 To UBound(Veri, 1), 1 To 1)
   
    For Each Fis_No In Dizi.Keys
        Kriter = Dizi.Item(Fis_No)(2)
       
        If Kriter Like "*|391*" And Kriter Like "*|120.02*" Then Kontrol_A = True
        If Kriter Like "*|191*" And Kriter Like "*|320.02*" Then Kontrol_A = True
       
        If Kriter Like "*|391*" And Kriter Like "*|120.01*" Then Kontrol_B = True
        If Kriter Like "*|191*" And Kriter Like "*|320.01*" Then Kontrol_B = True
       
        If Kontrol_A = True Then
            For X = Dizi.Item(Fis_No)(1) To Dizi.Item(Fis_No)(1) + Dizi.Item(Fis_No)(0) - 1
                Say = Say + 1
                Liste(X, 1) = "Ramada"
            Next
        End If
       
        If Kontrol_B = True Then
            For X = Dizi.Item(Fis_No)(1) To Dizi.Item(Fis_No)(1) + Dizi.Item(Fis_No)(0) - 1
                Say = Say + 1
                Liste(X, 1) = "Merkez"
            Next
        End If
       
        Kontrol_A = False
        Kontrol_B = False
    Next

    If Say > 0 Then
        S1.Range("J2").Resize(UBound(Veri, 1)) = Liste
        MsgBox "Lokasyon ayrımı yapılmıştır." & vbCrLf & vbCrLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If

    Set S1 = Nothing
    Set Dizi = Nothing
End Sub

Korhan Bey merhaba,

Bu konu ile ilgili bir detaydan dolayı tekrardan yardım istemek zorunda kaldım.

Şöyle, Verilerin arandığı F sütununda nadiren de olsa boş hücreler varmış. Bunun yeni farkına vardım. Bu boş hücrelerden dolayı, kod ilk boş hücreye rasladıktan sonra yadırılan verilerde satır kayması olmakta. Gerçek verilerden oluşan bir dosya ekledim ve boşluklu veri ve boşluksuz veri olmak üzere iki excel sayfasına yerleştirdim, kontrol edilebilmesi için.

Yaklaşık 360.000 verinin sonucunu 30-40 saniye arasında almaktayım. Ancak, eğer tabiki yanlış değilsem bu boş hücrelerden dolayı satırlarda kayma olmakta.

Şöyle yapılabilir mi, boş hücrelerin olduğu aynı fiş nolar atlanabilir mi, ya da bir alternatif olarak boş hücrelerin olduğu fiş nolar silinebilir mi. Boş hücrelerin olduğu fişleri verilerin arasından çıkardığım zaman kayma olmadığını gördüm.

Korhan Ayhan · 10 Nisan 2022

Merhaba,

#28 nolu mesajınızda paylaştığınız dosyanıza göre son kodu kurgulamıştım. Bu dosyanızda F sütunu ile ilgili hiçbir sorgulama yoktur. Tamamen A ve I sütunları üzerine sorgulamalar ve işlemler yapmıştık. I sütununda sizin kurguladığınız formüle göre fişleri sorgulamıştık. Bu sütundaki formülünüzde F sütunundan etkilenmiyor. Bu sebeple F sütunundaki boş hücrelerin hiçbir şeyi etkilememesi gerekir.

Bence asıl dosyanızı tekrar kontrol etmelisiniz.

walabi · 10 Nisan 2022

Korhan Ayhan' Alıntı:
Merhaba,

#28 nolu mesajınızda paylaştığınız dosyanıza göre son kodu kurgulamıştım. Bu dosyanızda F sütunu ile ilgili hiçbir sorgulama yoktur. Tamamen A ve I sütunları üzerine sorgulamalar ve işlemler yapmıştık. I sütununda sizin kurguladığınız formüle göre fişleri sorgulamıştık. Bu sütundaki formülünüzde F sütunundan etkilenmiyor. Bu sebeple F sütunundaki boş hücrelerin hiçbir şeyi etkilememesi gerekir.

Bence asıl dosyanızı tekrar kontrol etmelisiniz.

Merhaba, öncelikle özür dilerim, geç cevap verdiğim için ve sanırım daha da önemlisi eksik bilgi vermiş olduğum için.

Bu konu başlığı altında temelde iki işlev için bana yardımcı oldunuz. Benim bahsettiğim , konu başlığına açmama sebep olan ve sizin çözüm ürettiğiniz ilk kodlar, aşağıda kodun bendeki son işlevsel halini ekliyorum. Sanırım 7 nolu mesajdaydı. Eğer yanlış anlamadıysam bu kodların işleyişinde F ssütununda boş hücre varsa satırlarda kayma yapıyor. Ben böyle algıladım açıkcası. cevap yazdığınız bir önceki mesajımda da bu sebeple örnek dosya paylaştım. Ve tekrar paylaşıyorum.

Sub Fast_Vlookup_Dictionary()
Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
Dim Veri As Variant, X As Long, Son As Long
Dim Fatura_No As Variant, Fatura_Tipi As Variant
Dim Kontrol As Boolean, Y As Byte, Say As Long, Zaman As Double

Zaman = Timer

Set S1 = Sheets("Muavin")
Set S2 = Sheets("Fatura Türleri")
Set Dizi = VBA.CreateObject("Scripting.Dictionary")

Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
If Son = 2 Then Son = 3

Veri = S2.Range("B2:B" & Son).Value

For X = LBound(Veri, 1) To UBound(Veri, 1)
If Veri(X, 1) <> "" Then
If Not Dizi.Exists(Veri(X, 1)) Then
Say = Say + 1
Dizi.Add Veri(X, 1), Say
End If
End If
Next

Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
If Son = 2 Then Son = 3

Veri = S1.Range("A2:H" & Son).Value

ReDim Liste(1 To UBound(Veri, 1), 1 To 2)

Say = 0

For X = LBound(Veri, 1) To UBound(Veri, 1)
If Veri(X, 6) <> "" Then
Fatura_No = Split(Veri(X, 6), ",")
Say = Say + 1
For Y = LBound(Fatura_No) To UBound(Fatura_No)
If Len(Fatura_No(Y)) = 16 And IsNumeric(Right(Fatura_No(Y), 1)) And Fatura_No(Y) Like "*2022*" Then
Fatura_Tipi = Empty
For Each Fatura_Tipi In Dizi.Keys
If Veri(X, 6) Like "*" & Fatura_Tipi & "*" Then
Liste(Say, 1) = Fatura_No(Y)
Liste(Say, 2) = Fatura_Tipi
Kontrol = True
Exit For
End If
Next
End If
If Kontrol = True Then Exit For
Next
End If
Kontrol = False
Next

If Say > 0 Then
S1.Range("I2:J" & S1.Rows.Count).ClearContents
S1.Range("I2").Resize(Say).NumberFormat = "@"
S1.Range("I2").Resize(Say, 2) = Liste
End If

Dizi.RemoveAll
Erase Liste

Set S1 = Nothing
Set S2 = Nothing
Set Dizi = Nothing

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

Korhan Ayhan · 10 Nisan 2022

Mesajınızda FİŞ NO diye belirtince bende son kodla ilgili yazdığınzı düşünmüştüm.

Mesajınızda ilk kod diye belirtseydiniz böyle bir karışıklık yaşamazdık.

Kodu aşağıdaki gibi değiştirip deneyin bakalım sorun çözülecek mi?

C++:

Option Explicit

Sub Fast_Vlookup_Dictionary()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    Dim Veri As Variant, X As Long, Son As Long
    Dim Fatura_No As Variant, Fatura_Tipi As Variant
    Dim Kontrol As Boolean, Y As Byte, Say As Long, Zaman As Double
   
    Zaman = Timer
   
    Set S1 = Sheets("Muavin")
    Set S2 = Sheets("Modül_İşlem_Türleri")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
   
    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
   
    Veri = S2.Range("B2:B" & Son).Value
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            If Not Dizi.Exists(Veri(X, 1)) Then
                Say = Say + 1
                Dizi.Add Veri(X, 1), Say
            End If
        End If
    Next
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
   
    Veri = S1.Range("A2:H" & Son).Value
   
    ReDim Liste(1 To UBound(Veri, 1), 1 To 2)
    
    Say = 0
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Say = Say + 1
        If Veri(X, 6) <> "" Then
            Fatura_No = Split(Veri(X, 6), ",")
            For Y = LBound(Fatura_No) To UBound(Fatura_No)
                If Len(Fatura_No(Y)) = 16 And IsNumeric(Right(Fatura_No(Y), 1)) And Fatura_No(Y) Like "*2022*" Then
                    Fatura_Tipi = Empty
                    For Each Fatura_Tipi In Dizi.Keys
                        If Veri(X, 6) Like "*" & Fatura_Tipi & "*" Then
                            Liste(Say, 1) = Fatura_No(Y)
                            Liste(Say, 2) = Fatura_Tipi
                            Kontrol = True
                            Exit For
                        End If
                    Next
                End If
                If Kontrol = True Then Exit For
            Next
        End If
        Kontrol = False
    Next
   
    If Say > 0 Then
        S1.Range("I2:J" & S1.Rows.Count).ClearContents
        S1.Range("I2").Resize(Say).NumberFormat = "@"
        S1.Range("I2").Resize(Say, 2) = Liste
    End If

    Dizi.RemoveAll
    Erase Liste
   
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing

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

walabi · 10 Nisan 2022

Korhan Ayhan' Alıntı:

Mesajınızda FİŞ NO diye belirtince bende son kodla ilgili yazdığınzı düşünmüştüm.

Mesajınızda ilk kod diye belirtseydiniz böyle bir karışıklık yaşamazdık.

Kodu aşağıdaki gibi değiştirip deneyin bakalım sorun çözülecek mi?

C++:

Option Explicit

Sub Fast_Vlookup_Dictionary()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    Dim Veri As Variant, X As Long, Son As Long
    Dim Fatura_No As Variant, Fatura_Tipi As Variant
    Dim Kontrol As Boolean, Y As Byte, Say As Long, Zaman As Double
  
    Zaman = Timer
  
    Set S1 = Sheets("Muavin")
    Set S2 = Sheets("Modül_İşlem_Türleri")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
  
    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
  
    Veri = S2.Range("B2:B" & Son).Value
  
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            If Not Dizi.Exists(Veri(X, 1)) Then
                Say = Say + 1
                Dizi.Add Veri(X, 1), Say
            End If
        End If
    Next
  
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
  
    Veri = S1.Range("A2:H" & Son).Value
  
    ReDim Liste(1 To UBound(Veri, 1), 1 To 2)
   
    Say = 0
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Say = Say + 1
        If Veri(X, 6) <> "" Then
            Fatura_No = Split(Veri(X, 6), ",")
            For Y = LBound(Fatura_No) To UBound(Fatura_No)
                If Len(Fatura_No(Y)) = 16 And IsNumeric(Right(Fatura_No(Y), 1)) And Fatura_No(Y) Like "*2022*" Then
                    Fatura_Tipi = Empty
                    For Each Fatura_Tipi In Dizi.Keys
                        If Veri(X, 6) Like "*" & Fatura_Tipi & "*" Then
                            Liste(Say, 1) = Fatura_No(Y)
                            Liste(Say, 2) = Fatura_Tipi
                            Kontrol = True
                            Exit For
                        End If
                    Next
                End If
                If Kontrol = True Then Exit For
            Next
        End If
        Kontrol = False
    Next
  
    If Say > 0 Then
        S1.Range("I2:J" & S1.Rows.Count).ClearContents
        S1.Range("I2").Resize(Say).NumberFormat = "@"
        S1.Range("I2").Resize(Say, 2) = Liste
    End If

    Dizi.RemoveAll
    Erase Liste
  
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing

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

Teşekkürler, bu hali ile kayma yapmıyor, ellerinize sağlık. Karışıklık için tekrar özür.

Soru VLookup / Düşeyara Daha hızlı kod yada alternatif

Korhan Ayhan

Administrator

walabi

Ekli dosyalar

Korhan Ayhan

Administrator

walabi

Korhan Ayhan

Administrator

walabi

Korhan Ayhan

Administrator

walabi

Ekli dosyalar

Korhan Ayhan

Administrator

walabi

walabi

Ekli dosyalar

Korhan Ayhan

Administrator

walabi

Ekli dosyalar

Korhan Ayhan

Administrator

walabi