yavaş çalışan vba kodu

[euphrates55]

merhaba. elimde aşağıdaki 2 kod var ve hatrı sayılır şekilde kullanıyorum. yaklaşık 1600 satır aralığında yaptığım bu işlem yaklaşık olarak 2,5 dk sürüyor. kodu aşağıya bıraksam bir yerde yavaşlatan bir şey var mı diye bakarsanız sevinirim.

Sub FormulKopyala()
    Dim i As Integer
    xy = InputBox("başlangıç hücresini yaz")

    If xy = "" Then
MsgBox "başlangıç hücresini yazmadınız.", vbInformation, "        Uyarı"
 Exit Sub
End If
 sh = InputBox("son satır sayısı (harfsiz)")
    If sh = "" Then
MsgBox "son satır numarasını yazmadınız.", vbInformation, "        Uyarı"
Exit Sub
End If

    X = Range("" & xy & "").Row
    y = Range("" & xy & "").Column
    For i = X To sh Step 6
          Cells(X, y).Copy Cells(i, y)
    Next

End Sub

Sub FormulKopyaladegeryapistir()
    Dim i As Integer
xy = InputBox("kopyalanacak başlangıç hücresini yaz")
    If xy = "" Then
    MsgBox "kopyalanacak başlangıç hücresini yazmadınız.", vbInformation, "        Uyarı"
    Exit Sub
    End If
ab = InputBox("yapıştırılacak başlangıç hücresini yaz")
    If ab = "" Then
    MsgBox "yapıştırılacak başlangıç hücresini yazmadınız.", vbInformation, "        Uyarı"
    Exit Sub
    End If
sh = InputBox("son satır sayısı (harfsiz)")
    If sh = "" Then
    MsgBox "son satır numarasını yazmadınız.", vbInformation, "        Uyarı"
    Exit Sub
    End If


    X = Range("" & xy & "").Row
    y = Range("" & xy & "").Column
    a = Range("" & ab & "").Row
    b = Range("" & ab & "").Column

 
    For i = X To sh Step 6
    Cells(i, y).Copy
    Cells(i, b).PasteSpecial Paste:=xlPasteValues
    Next i

    MsgBox "T A M A M", vbInformation, "        Uyarı"
End Sub

 

[catalinastrap]

merhaba. elimde aşağıdaki 2 kod var ve hatrı sayılır şekilde kullanıyorum. yaklaşık 1600 satır aralığında yaptığım bu işlem yaklaşık olarak 2,5 dk sürüyor. kodu aşağıya bıraksam bir yerde yavaşlatan bir şey var mı diye bakarsanız sevinirim.

Sub FormulKopyala()
    Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    Dim i As Integer
    xy = InputBox("başlangıç hücresini yaz")

    If xy = "" Then
MsgBox "başlangıç hücresini yazmadınız.", vbInformation, "        Uyarı"
Exit Sub
End If
sh = InputBox("son satır sayısı (harfsiz)")
    If sh = "" Then
MsgBox "son satır numarasını yazmadınız.", vbInformation, "        Uyarı"
Exit Sub
End If

    X = Range("" & xy & "").Row
    y = Range("" & xy & "").Column
    For i = X To sh Step 6
          Cells(X, y).Copy Cells(i, y)
    Next

End Sub

Sub FormulKopyaladegeryapistir()
    Dim i As Integer
xy = InputBox("kopyalanacak başlangıç hücresini yaz")
    If xy = "" Then
    MsgBox "kopyalanacak başlangıç hücresini yazmadınız.", vbInformation, "        Uyarı"
    Exit Sub
    End If
ab = InputBox("yapıştırılacak başlangıç hücresini yaz")
    If ab = "" Then
    MsgBox "yapıştırılacak başlangıç hücresini yazmadınız.", vbInformation, "        Uyarı"
    Exit Sub
    End If
sh = InputBox("son satır sayısı (harfsiz)")
    If sh = "" Then
    MsgBox "son satır numarasını yazmadınız.", vbInformation, "        Uyarı"
    Exit Sub
    End If


    X = Range("" & xy & "").Row
    y = Range("" & xy & "").Column
    a = Range("" & ab & "").Row
    b = Range("" & ab & "").Column


    For i = X To sh Step 6
    Cells(i, y).Copy
    Cells(i, b).PasteSpecial Paste:=xlPasteValues
    Next i

    MsgBox "T A M A M", vbInformation, "        Uyarı"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Bu şekilde bir denermisiniz ?

 

[euphrates55]

cevabınızı geç gördüm kusura bakmayın. teşekkürler.

 

[catalinastrap]

Rica ederim kolay gelsin