Örnek dosyadaki makroyu hızlandırmama yardımcı olur musunuz?

[Tevfik_Kursun]

Merhaba Arkadaşlar,
H sütununda, öğrencilerin isimlerin baş harfleri var
I, J, K, L M sütunlarında ise H sütunundaki ismin baş harflerinin ad soyad olarak ikişerli yazılışıdır
O2 ye yazılan iki harf, I, J, K, L M sütunlarında kaçıncı satırlarda olduğunu P2 den itibaren sıralarken, Q sütunundaki aynı hizaya H sütunundaki hücredekileri getirmek istiyorum.
Hazırladığım makro bu işlemi en az 25 saniyede yapıyor. Diziye alma yöntemiyle çok hızlanacağını düşünüyorum. Yardımcı olursanız sevinirim.
Saygılarımla

 

[Levent Menteşoğlu]

Aşağıdaki gibi deneyin.

Sub kontrol()

Dim satir As Range

[P:Q].ClearContents

metin = "*" & Left([O2], 1) & "*" & Right([O2], 1) & "*"
say = WorksheetFunction.CountIf([I:M], metin)
[S2] = "kişi": [R2] = say

Set satir = [I:M].Find(metin)
Cells(2, "P") = satir.Row
Cells(2, "Q") = satir

Do Until deg = say - 1
deg = deg + 1
Set satir = [I:M].FindNext(satir)
Cells(deg + 2, "P") = satir.Row
Cells(deg + 2, "Q") = Cells(satir.Row, "H")
Loop

End Sub

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Sub Kontrol()
    Dim Veri As Variant, X As Long, Y As Byte, Say As Long
    Dim Aranan As Variant, Son As Long, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Range("P:S").Clear
    
    Son = Cells(Rows.Count, "H").End(3).Row
    
    Veri = Range("H1:M" & Son).Value
    
    ReDim Liste(1 To UBound(Veri, 1), 1 To 2)
    
    Aranan = UCase(Replace(Replace(Range("O2").Value, "ı", "I"), "i", "İ"))
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        For Y = 2 To UBound(Veri, 2)
            If UCase(Replace(Replace(Veri(X, Y), "ı", "I"), "i", "İ")) = Aranan Then
                Say = Say + 1
                Liste(Say, 1) = X
                Liste(Say, 2) = Veri(X, 1)
            End If
        Next
    Next
    
    If Say > 0 Then
        Range("P2").Resize(Say, 2) = Liste
        Range("R2") = Say
        Range("S2") = "Kişi"
        Columns("P:Q").AutoFit
    End If

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

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

 

[Tevfik_Kursun]

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

 

[Tevfik_Kursun]

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

 

[Tevfik_Kursun]

Günaydın Sayın Hocalarım,
Tekrar ilgilerinize çok teşekkür ederim. Saniyenin kesri içinde bilgiler geliyor.
Ama hala Korhan Hocamın diziye alma yöntemini kavrayamadığımı anladım. İlk 7 sütunda da bilgi var, bundan, uyarlayabilirim düşüncesiyle söz etmemiştim, ama uyarlayamadım. Yaşlılık yerleşti sanırım. Kavramayı isterdim. Halbuki dizi için tavsiyelerinizi de uygulamıştım.
Levent Hocamın yöntemiyle çözdüğüm için de mutluyum.
Saygılarımla

 

[Korhan Ayhan]

Neresini kavrayamadınız. Anlatalım..

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
Süpersiniz, ilginize çok teşekkür ederim.
Satır numaralarını yazıktan sonra ki hücrelere A:G sütunundakileri almak istiyorum. Yapmam gereken değişikliği tarif ederseniz minnettar kalırım. Bilgiler gerçek olduğu için ortaya koyamadım.
Saygılarımla

 

[Korhan Ayhan]

Satır numaraları ve H sütunundaki bilgiyi yazdırmıştık.

Son dizilim nasıl olacak?

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
Şöyle bir öteleme yaptım. Arananı O2 yerine Q2 den alıyor. R sütununa satır numaralarını, devamında da A dan G sütununa kadar ne varsa sıralıyorum. Değişiklikle daha kolay kavrayabilirim diye düşünüyorum. (torunum araya girdi, o nedenle gecikti. Kusura bakmayın lütfen)
Saygılarımla

 

[Korhan Ayhan]

H sütunu sanırım iptal oldu.

 

[Tevfik_Kursun]

Kavradıktan sonra eklemek kolay sayın hocam

 

[Korhan Ayhan]

Peki bu değişikliklerle kavrayabileceğinizi düşünüyor musunuz?

 

[Tevfik_Kursun]

İnşallah, şiddetle umuyorum
Saygılarımla

 

[Korhan Ayhan]

İnceleyiniz.

Option Explicit

Sub Kontrol()
    Dim Veri As Variant, X As Long, Y As Byte, Say As Long
    Dim Aranan As Variant, Son As Long, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Range("R:Y").Clear
    
    Son = Cells(Rows.Count, "A").End(3).Row
    
    Veri = Range("A1:M" & Son).Value
    
    ReDim Liste(1 To UBound(Veri, 1), 1 To 8)
    
    Aranan = UCase(Replace(Replace(Range("Q2").Value, "ı", "I"), "i", "İ"))
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        For Y = 2 To UBound(Veri, 2)
            If UCase(Replace(Replace(Veri(X, Y), "ı", "I"), "i", "İ")) = Aranan Then
                Say = Say + 1
                Liste(Say, 1) = X
                Liste(Say, 2) = Veri(X, 1)
                Liste(Say, 3) = Veri(X, 2)
                Liste(Say, 4) = Veri(X, 3)
                Liste(Say, 5) = Veri(X, 4)
                Liste(Say, 6) = Veri(X, 5)
                Liste(Say, 7) = Veri(X, 6)
                Liste(Say, 8) = Veri(X, 7)
            End If
        Next
    Next
    
    If Say > 0 Then
        Range("R2").Resize(Say, 8) = Liste
        Range("Q1") = Say
        Range("R1") = "Kişi"
        Columns("R:Z").AutoFit
    End If

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

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

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
Buraya kadarını ben de yapmıştım. Bu durumda gelen sonuçlar ikişer defa geliyor. Bunun sebebini bulamamıştım, ayrıca ilk satırda S2 ye israrla isteneni getirtememiştim.
Saygılarımla

 

[Korhan Ayhan]

Tevfik Bey,

Aranan veriyi çoklu sütunda arıyorsunuz.

Diyelim ki mz verisi 19. satırda hem J sütununda hem de L sütununda var. Bu durumda görmek istediğiniz sonuç ne olur?

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
Şimdi anladım, tamam, o zaman H sütununu aradan çıkarır tam sağa alırım, problem çözülür.
Çok teşekkür ederim.
Saygılarımla

 

[Korhan Ayhan]

Bence H sütununu aradan çıkarmayın madem öğrenmek ve anlamak istiyorsunuz kodları zorlayın. Bu haliyle H sütununu da koda eklemeye çalışın.

O zaman öğrenmiş ve anlamış olursunuz..

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
Tekrar, tekrar teşekkür ederim. Şahsınızda, tüm arkadaşlara, site yöneticilerine teşekkür ederim. İyi ki varsınız.
Saygılarımla