Çözüldü Hücre İçerisinde Belirtilen Koşula Göre Arama Yapma/Aktarma

Option Explicit
Sub Bul_Aktar()
    Dim S1  As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim Son_S1 As Long, Son_S2 As Long, Zaman As Double, Satir As Long
    Dim Veri As Variant, Aranan As Variant, X As Long, d As Object, krt
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Zaman = Timer
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set S3 = Sheets("Sayfa3")
    
    S3.Range("A2:A" & Rows.Count).Clear
    S3.Range("C2:C" & Rows.Count).Clear
    
    Son_S2 = S2.Cells(Rows.Count, 4).End(3).Row
    
    Veri = S2.Range("A2:E" & Son_S2).Value
    Son_S1 = S1.Cells(Rows.Count, 3).End(3).Row
    Aranan = S1.Range("C2:C" & Son_S1).Value
    
    Set d = CreateObject("scripting.dictionary")
    
    For X = 1 To UBound(Aranan)
        krt = CStr(Aranan(X, 1))
        d(krt) = krt
    Next X
    
    ReDim Liste(1 To UBound(Veri), 1 To 3)
    For X = 1 To UBound(Veri)
        krt = CStr(Left(Veri(X, 4), 6))
        If d.exists(krt) Then
            Satir = Satir + 1
            Liste(Satir, 1) = Veri(X, 1)
            Liste(Satir, 1) = Veri(X, 2)
            Liste(Satir, 3) = Veri(X, 4)
        End If
    Next X

    If Satir > 0 Then
        S3.Range("A2:C" & Rows.Count).NumberFormat = "@"
        S3.Range("A2:C" & Satir + 1).Value = Liste
    End If
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00")
End Sub