Örnek dosyada 21 sn de yapılan iş, esas dosyada 1 saat sürüyor

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Bu makro, bu dosyada 21 saniyede işini bitiriyor. Olması gereken dosyada 1 saat bekledim, sonra çalışmasını ben durdurdum.
Sebebi ne olabilir?
Diziye alma yöntemi hızlandırır mı, hızlandırırsa nasıl?
Saygılarımla
Ornek_71

 

[Korhan Ayhan]

Siz 1-400 arası değerleri kontrol etmişsiniz.

Bunu yerine sadece listede olan değerler listelense işinizi görüyor mu?

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
Sıra şart değil, ama bu oluşturulanla eşleşsin yeter.
Saygılarımla

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Varsa_Getir()
    Dim Veri As Variant, Son As Long, X As Long
    Dim Dizi As Object, Zaman As Double, Say As Long
        
    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")

    Range("Q5:R404").ClearContents
    
    Son = Cells(Rows.Count, 2).End(3).Row
    Veri = Range("B5:I" & Son).Value
    
    ReDim Liste(1 To 400, 1 To 2)
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 8) <> "" Then
            If Not Dizi.Exists(Veri(X, 8)) Then
                Say = Say + 1
                Dizi.Add Veri(X, 8), Say
                Liste(Say, 1) = Say
                Liste(Say, 2) = Veri(X, 1)
            Else
                Liste(Dizi.Item(Veri(X, 8)), 2) = Liste(Dizi.Item(Veri(X, 8)), 2) & Veri(X, 1)
            End If
        End If
    Next
    
    Range("Q5").Resize(Say, 2) = Liste

    Set Dizi = Nothing

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

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
İlginize çok teşekkür ederim. Sıra şart değil, ama Q sütununa kimi saydığı gelirse olur, yoksa bu sadece kargaşa! Sayma önemli gibi, bir sütun artsa ne olur ki?
Saygılarımla

 

[Korhan Ayhan]

Bu kod sizin dosyanızda ki yaptığınız şekilde işlem yapar.

Option Explicit

Sub Varsa_Getir()
    Dim Veri As Variant, Son As Long, X As Long
    Dim Dizi As Object, Zaman As Double, Say As Long
        
    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")

    Range("Q5:R404").ClearContents
    
    Son = Cells(Rows.Count, 2).End(3).Row
    Veri = Range("B5:I" & Son).Value
    
    ReDim Liste(1 To 400, 1 To 2)
    
    For X = 1 To 400
        Dizi.Item(X) = X
        Liste(X, 1) = X
    Next
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 8) <> "" Then
            If Dizi.Exists(Veri(X, 8)) Then
                Liste(Dizi.Item(Veri(X, 8)), 1) = Dizi.Item(Veri(X, 8))
                Liste(Dizi.Item(Veri(X, 8)), 2) = Liste(Dizi.Item(Veri(X, 8)), 2) & Veri(X, 1)
            End If
        End If
    Next
    
    Range("Q5").Resize(400, 2) = Liste

    Set Dizi = Nothing

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

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
İlginize çok teşekkür ederim. Muhteşem. Diziye alma işlemini bir türlü öğrenemedim.
Saygılarımla

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
İlginize tekrar çok teşekkür ederim, evde kaldığımız bu günlerde Özet Tablo dan sonra Dizi konusuna da el atmamı sağladığınız için.
Ekli dosyada yardımcı makro kullanarak dizi uygulamaları oluşturdum. Yardımcı makro kullanmadan Varsa_Getir makrolarında nasıl ekleme yapılırsa aynı sonuçlara ulaşılır? (S sütunu, sadece yapılan işin doğruluğunu görmek için hazırlandı.)
Saygılarımla

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Varsa_Getir_Ay()
    Dim Veri As Variant, Son As Long, X As Long, Ay As Byte
    Dim Dizi As Object, Zaman As Double, Say As Long

    Zaman = Timer

    Range("Q5:S504").ClearContents

    Set Dizi = CreateObject("Scripting.Dictionary")

    Son = Cells(Rows.Count, 2).End(3).Row
    Veri = Range("B5:H" & Son).Value
    
    ReDim Liste(1 To [B2], 1 To 2)
    
    For X = 1 To [B2]
        Dizi.Item(X) = X
        Liste(X, 1) = X
    Next
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 7) <> "" Then
            Ay = Month(Veri(X, 7))
            If Dizi.Exists(Ay) Then
                Liste(Dizi.Item(Ay), 1) = Dizi.Item(Ay)
                Liste(Dizi.Item(Ay), 2) = Liste(Dizi.Item(Ay), 2) & Veri(X, 1)
            End If
        End If
    Next
    
    Range("Q5").Resize([B2], 2) = Liste

    Set Dizi = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Sub Varsa_Getir_Hafta()
    Dim Veri As Variant, Son As Long, X As Long, Hafta As Byte
    Dim Dizi As Object, Zaman As Double, Say As Long

    Zaman = Timer

    Range("Q5:S504").ClearContents
    
    Set Dizi = CreateObject("Scripting.Dictionary")

    Son = Cells(Rows.Count, 2).End(3).Row
    Veri = Range("B5:H" & Son).Value
    
    ReDim Liste(1 To [C2], 1 To 2)
    
    For X = 1 To [C2]
        Dizi.Item(X) = X
        Liste(X, 1) = X
    Next
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 7) <> "" Then
            Hafta = Application.WeekNum(Veri(X, 7))
            If Dizi.Exists(Hafta) Then
                Liste(Dizi.Item(Hafta), 1) = Dizi.Item(Hafta)
                Liste(Dizi.Item(Hafta), 2) = Liste(Dizi.Item(Hafta), 2) & Veri(X, 1)
            End If
        End If
    Next
    
    Range("Q5").Resize([C2], 2) = Liste

    Set Dizi = Nothing

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

Sub Varsa_Getir_Gun()
    Dim Veri As Variant, Son As Long, X As Long, Gun_Say As Integer
    Dim Dizi As Object, Zaman As Double, Say As Long, Baslangic_Tarihi As Date

    Zaman = Timer

    Range("Q5:S504").ClearContents

    Set Dizi = CreateObject("Scripting.Dictionary")

    Son = Cells(Rows.Count, 2).End(3).Row
    Veri = Range("B5:H" & Son).Value
    
    Baslangic_Tarihi = Range("A1").Value
    
    ReDim Liste(1 To [D2], 1 To 2)
    
    For X = 1 To [D2]
        Dizi.Item(X) = X
        Liste(X, 1) = X
    Next
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 7) <> "" Then
            Gun_Say = Veri(X, 7) - Baslangic_Tarihi + 1
            If Dizi.Exists(Gun_Say) Then
                Liste(Dizi.Item(Gun_Say), 1) = Dizi.Item(Gun_Say)
                Liste(Dizi.Item(Gun_Say), 2) = Liste(Dizi.Item(Gun_Say), 2) & Veri(X, 1)
            End If
        End If
    Next
    
    Range("Q5").Resize([D2], 2) = Liste

    Set Dizi = Nothing

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

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
İlginize çok teşekkür ederim. Varsa_Getir_Gun makrosunda hata var, GÜN ile toparlıyor. Halbuki GÜNSAY ile toparlaması lazım. 111 günün tamamı 31 gün içine yerleşiyor.
Saygılarımla

 

[Korhan Ayhan]

Üstte ki mesajımda GÜN bölümündeki problemi düzelttim. Tekrar deneyiniz.

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
İlginize çok teşekkür ederim.
Saygılarımla