Yavaş çalışan kod

[Nadir]

Aşağıdaki kod çok veri aktarımı olduğu zaman yavaş çalışıyor. Daha hızlı koda ihtiyacım var.

Sub aktar()
Dim s As Integer
Dim sat As Integer
Dim say As Integer

sat = Sheets("KAYIT").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Row
son = Sheets("FATURA").Cells(Rows.Count, "B").End(3).Row
For s = 3 To son Step 1
If Sheets("FATURA").Cells(s, "B") <> "" Then

Sheets("KAYIT").Cells(sat, "B").Value = Sheets("FATURA").Cells(s, "B")
Sheets("KAYIT").Cells(sat, "C").Value = Sheets("FATURA").Cells(s, "C")
Sheets("KAYIT").Cells(sat, "D").Value = Sheets("FATURA").Cells(s, "D")
Sheets("KAYIT").Cells(sat, "E").Value = Sheets("FATURA").Cells(s, "E")
Sheets("KAYIT").Cells(sat, "F").Value = Sheets("FATURA").Cells(s, "F")
Sheets("KAYIT").Cells(sat, "G").Value = Sheets("FATURA").Cells(s, "G")
Sheets("KAYIT").Cells(sat, "H").Value = Sheets("FATURA").Cells(s, "L")
sat = sat + 1
say = say + 1
End If
Next s
End Sub

 

[Orion1]

Aşağıdaki gibi deneyiniz.

Sub aktar()
Dim s As Long
Dim sat As Long
Dim say As Long

sat = Sheets("KAYIT").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Row
son = Sheets("FATURA").Cells(Rows.Count, "B").End(3).Row
Application.ScreenUpdating = False
For s = 3 To son
If Sheets("FATURA").Cells(s, "B") <> "" Then
Sheets("KAYIT").Range("B" & sat & ":G" & sat).Value = _
        Sheets("FATURA").Range("B" & s & ":G" & s).Value
Sheets("KAYIT").Cells(sat, "H").Value = Sheets("FATURA").Cells(s, "L")
sat = sat + 1
say = say + 1
End If
Next s
Application.ScreenUpdating = True
End Sub

 

[Nadir]

Teşekkürler Evren bey, Hızır gibisiniz.

350 satırlık kayıt aktarımı 10 saniye kadar sürdü. Önceki koda göre gayet iyi..

Kopyala-Yapıştır daha hızlı ama... aktarılan veri satırı sayısı değişken olduğu için kontrol etmek zor.

 

[alicimri]

Sayın Orion1 cevap vermiş, sildim.

 

[ÖmerBey]

Alternatif olsun bari:

Sub aktar()
Dim s As Integer
Dim sat As Integer
Dim say As Integer
Dim alan As Range
sat = Sheets("KAYIT").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Row
son = Sheets("FATURA").Cells(Rows.Count, "B").End(3).Row
For s = 3 To son Step 1
If Sheets("FATURA").Cells(s, "B") <> "" Then
    If alan Is Nothing Then
        Set alan = Sheets("FATURA").Range("B" & s & ":G" & s & ",L" & s)
    Else
        Set alan = Union(alan, Sheets("FATURA").Range("B" & s & ":G" & s & ",L" & s))
    End If
End If
Next s
alan.Copy
Sheets("KAYIT").Range("B" & sat).PasteSpecial xlPasteValues
End Sub

 

[Nadir]

Teşekkürler mucit bey, 500 satırlık kaydın aktarması 1 saniye...
İyi geceler.