Veri Aktarma

[Ahmet Sami]

İyi günler diliyorum, elim de aşağıdaki gibi bir veri aktarma kodu var yaklaşık 2500 kişi aktarıyorum, aktarma işlemi yaklaşık 3 veya 4 dakika sürüyor kodu yeniden düzenleyerek daha hızlı aktarma yapabilir miyiz. Teşekkür ederim.

Sub BODROAKTAR()

On Error Resume Next

Set S1 = Sheets("ÖDEME")
Set s3 = Sheets("BODRO")

s3.Range("A2:J3000").ClearContents

sat = s3.[B3000].End(3).Row + 1

Application.ScreenUpdating = False

For y = 2 To S1.[a3000].End(3).Row + 1
If S1.Cells(y, 2).Value > 0 Then
s3.Cells(sat, 1).Value = S1.Cells(y, 1).Value
s3.Cells(sat, 2).Value = S1.Cells(y, 2).Value
s3.Cells(sat, 3).Value = S1.Cells(y, 3).Value
s3.Cells(sat, 4).Value = S1.Cells(y, 8).Value
s3.Cells(sat, 5).Value = S1.Cells(y, 4).Value
s3.Cells(sat, 6).Value = S1.Cells(y, 9).Value
s3.Cells(sat, 7).Value = S1.Cells(y, 12).Value
s3.Cells(sat, 8).Value = S1.Cells(y, 13).Value
s3.Cells(sat, 9).Value = S1.Cells(y, 14).Value
s3.Cells(sat, 10).Value = S1.Cells(y, 15).Value
sat = sat + 1

End If
Next


MsgBox "Ödeme Aktarıldı", , ""
Application.ScreenUpdating = True


End Sub

 

[PLİNT]

Merhaba
Aşağıdaki kodlarla bir deneyiniz.

[SIZE="2"]Sub BODROAKTAR()
On Error Resume Next
Dim list()
Set s1 = Sheets("ÖDEME")
Set S3 = Sheets("BODRO")
S3.Range("A2:J3000").ClearContents
sat = S3.[B3000].End(3).Row + 1
Application.ScreenUpdating = False
ReDim list(1 To 10, 1 To [COLOR="Blue"]s1.[a3000].End(3).Row + 1[/COLOR])
Application.Calculation = xlCalculationManual
For y = 2 To s1.[a3000].End(3).Row + 1
If s1.Cells(y, 2).Value > 0 Then
s1.Cells(y, 1).Select
i = i + 1
list(1, i) = s1.Cells(y, 1).Value
list(2, i) = s1.Cells(y, 2).Value
list(3, i) = s1.Cells(y, 3).Value
list(4, i) = s1.Cells(y, 8).Value
list(5, i) = s1.Cells(y, 4).Value
list(6, i) = s1.Cells(y, 9).Value
list(7, i) = s1.Cells(y, 12).Value
list(8, i) = s1.Cells(y, 13).Value
list(9, i) = s1.Cells(y, 14).Value
list(10, i) = s1.Cells(y, 15).Value
End If
Next
ReDim Preserve list(1 To 10, 1 To i)
S3.Range("A2").Resize(i, 10) = Application.Transpose(list)
Erase list
MsgBox "Ödeme Aktarıldı", , ""
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub[/SIZE]

 

[Ahmet Sami]

İl dışına çıkmam gerektiğinden bakamamıştım Sayın PLİNT çok teşekkür ederim elinize sağlık tam istediğim gibi oldu.