Kullandığım makro daha da hızlandırılır mı?

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Bu çalışma için oluşturabildiğim makronun daha da hızlandırılması mümkün müdür? Yardımcı olursanız sevinirim.
Saygılarımla

Ornek_Dosya

 

[veyselemre]

Sub test()
    Dim lst, say&, i&, ii&, bl, itms, kys, param(1 To 3)
    
    With Application
        param(1) = .ScreenUpdating: .ScreenUpdating = False
        param(2) = .EnableEvents: .EnableEvents = False
        param(3) = .Calculation: .Calculation = xlCalculationManual
    End With
    
    lst = Range("A1:A" & Cells(Rows.Count, 1).End(3).Row).Value
    kys = Range("H3:H" & Cells(Rows.Count, 8).End(3).Row).Value
    Range("I:AC").ClearContents
    Cells(2, "I").Resize(, UBound(kys)).Value = Application.Transpose(kys)
    
    For ii = LBound(kys) To UBound(kys)
        kys(ii, 1) = Trim(Replace(Replace(kys(ii, 1), """", ""), ":", ""))
    Next ii
    
    With CreateObject("Scripting.Dictionary")
        
        For i = 1 To UBound(lst)
            If InStr(lst(i, 1), "rawResults") Then
                .Item(say) = i
                say = say + 1
            End If
        Next i
        
        .Item(say) = i - 1
        itms = .items

        For i = 0 To UBound(itms) - 1
            .RemoveAll
            For ii = itms(i) To itms(i + 1) - 1
                If InStr(lst(ii, 1), ":") > 0 Then
                    bl = Split(Replace(lst(ii, 1), """", ""), ":")
                    .Item(Trim(bl(0))) = Trim(bl(1))
                End If
            Next ii
            For ii = LBound(kys) To UBound(kys)
                If .exists(kys(ii, 1)) Then
                    Cells(i + 3, ii + 8).Value = .Item(kys(ii, 1))
                End If
            Next ii
            say = say + 1
        Next i

    End With

    With Application
        .ScreenUpdating = param(1)
        .EnableEvents = param(2)
        .Calculation = param(3)
    End With
    
End Sub

 

[Tevfik_Kursun]

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