vba kod hızlandırma

[sevensuleyman]

merhaba ; "Güncelleme Bilgileri" Adlı Sayfama "YENİ ESKİ" olan sayadan verileri getirmekteyim. veri 5000 civarına çıktığı zaman çok fazla bekletmektedir. nasıl hızlandırılabilir. "Güncelleme Bilgileri" nde verilerin bulunduğu sütun A,B,C,D sütunlarıdır. yardımcı olursanız sevinirim

Dim s1 As Worksheet, i As Long, sat As Long, j As Byte
    
    Set s1 = Sheets("YENİ ESKİ")
    
    Application.ScreenUpdating = False
    Sheets("Güncelleme Bilgileri").Select
    Range("A2:Z" & Rows.Count).ClearContents
    
    sat = 2
    For i = 2 To s1.Cells(Rows.Count, "A").End(xlUp).Row
        
 
        
        Cells(sat, "A") = s1.Cells(i, "I")
        Cells(sat, "B") = s1.Cells(i, "J")
        Cells(sat, "C") = s1.Cells(i, "K")
        Cells(sat, "D") = s1.Cells(i, "L")
        
        
        sat = sat + 1
        

    Next i
    
    'Range("A1").Select
    'Application.CutCopyMode = False
    
    
    Range("A1:D" & Cells(Rows.Count, 2).End(3).Row).Sort Range("A1"), Order1:=xlAscending, Header:=xlYes
    
    Range("A2").Select
    
        For t = 60000 To 3 Step -1
    If Cells(t, "A") = "" Then
    Rows(t).Delete
    End If
Next

    
    
    
    
    Sheets("Güncelleme Bilgileri").Copy
    Set s2 = ActiveSheet
    
    Application.Calculation = xlCalculationManual
    
    
    
    s2.Range("A2:D" & s2.Rows.Count).Copy
        
    
    s2.Range("A2").PasteSpecial xlPasteValues
    
    

    
    
    Son = s2.Cells(s2.Rows.Count, 2).End(3).Row + 1
    s2.Range("A" & Son & ":A" & Rows.Count).EntireRow.Delete xlUp
    s2.Range("A1").Select
    
    
    
    
    
    
    
    
    'Sheets("Güncelleme Bilgileri").Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "OZMMM_TEK_Stok_Güncelleme" & Format(Now, "( dd.mm.yyyy_hh.mm )") & ".xlsx", 51
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
    

  
    
    MsgBox "Aktarım Bitti.", vbInformation
    
End Sub

 

[ÖmerFaruk]

sat=2
.......
Next i

bu satırları komple silip (arasındakiler de dahil) aşağıdaki şekilde dener misin?

SonSatır = S1.Cells(Rows.Count, "A").End(xlUp).Row
S1.Range("I2:J" & SonSatır).Copy
Range("A2").PasteSpecial (xlPasteValues)

 

[halit3]

Application.ScreenUpdating = False
bunun yerine aşağıdaki kodu ekle

With Application
.ScreenUpdating = False
.Calculation = xlAutomatic
End With
'-------------------------------------------

Application.DisplayAlerts = True

bunun hemen altına bunu ekle

With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
End With