koşullu kopya makrosu

[redje]

Merhabalar
Aşağıda bulunan makro işimi görmekte fakat kayıt sayı 500 ün üzerinde olduğu için
nerdeyse 10 dakika aktarım sürmekte hızlandırmam için ne yapabilirim
bilgi için teşekkürler.


sub pauntajaktar()

Dim i As Long, sat As Long, Sb As Worksheet

Set Sb = Sheets("hamhali")

Application.ScreenUpdating = False

Sheets("puançalışma").Select
Range("b61:b" & Rows.Count).ClearContents
Range("o61" & Rows.Count).ClearContents
Range("l61:N" & Rows.Count).ClearContents
sat = 3
For i = 2 To Sb.Cells(Rows.Count, "B").End(xlUp).Row
If Left(Sb.Cells(i, "l"), 1) <> "" And Sb.Cells(i, "AG") <> "tam" Then


Cells(sat, 1).Value = sat - 2
Range("b" & sat) = Sb.Cells(i, "b")
Range("j" & sat) = Sb.Cells(i, "l")
Range("h" & sat) = Sb.Cells(i, "ı")
Range("ı" & sat) = Sb.Cells(i, "j")
Range("m" & sat) = Sb.Cells(i, "m")
Range("g" & sat) = Sb.Cells(i, "h")
Range("N" & sat) = Sb.Cells(i, "O")

Range("c3").Copy Range("c" & sat)
Range("d3").Copy Range("d" & sat)
Range("e3").Copy Range("e" & sat)
Range("f3").Copy Range("f" & sat)
Range("k3").Copy Range("k" & sat)

sat = sat + 1
End If
Next i

Application.ScreenUpdating = True

Sheets("puançalışma").Select
Range("N2").Select
End Sub