Koşullu Aktarma "x"

[vivident]

Merhaba
Ekteki dosyamda iki adet problemim var

1) FORM (II) Sayfasından Arşiv sayfasına veri taşıyorum. Problem yok. Sadece isteğim K5:K55 arasında "X" işaretli olan satırları arşiv dosyasına taşımasın


2) FORM (II) Sayfamın B3:J3 arasındaki hücreleri E5:E55 arasının dolu olmasına bakarak kopyalama yapıyor. Problem yok. Sadece sanki bana adım adım yaptığı için yavaş geliyor. Daha hızlı nasıl olabilir

1) Sorum için kullandığım kodlar

Sub AktarII()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("Arsiv").Unprotect "6551"
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("FORM (II)")
Set s2 = ThisWorkbook.Worksheets("Arsiv")
sonsatir = s2.Range("B65536").End(xlUp).Row + 1
For i = 5 To 55
s2.Cells(sonsatir, 6) = s1.Cells(i, 4)
s2.Cells(sonsatir, 7) = s1.Cells(i, 5)
s2.Cells(sonsatir, 11) = s1.Cells(i, 9)
s2.Cells(sonsatir, 2) = s1.Cells(i, 2)
s2.Cells(sonsatir, 8) = s1.Cells(i, 6)
s2.Cells(sonsatir, 9) = s1.Cells(i, 7)
s2.Cells(sonsatir, 12) = s1.Cells(i, 10)
s2.Cells(sonsatir, 10) = s1.Cells(i, 9)
s2.Cells(sonsatir, 5) = s1.Cells(i, 3)
sonsatir = sonsatir + 1
Next i
Sheets("Arsiv").Select
Application.ScreenUpdating = True
Sheets("Arsiv").Protect "6551"
MsgBox "Veriler arşiv sayfasına aktarılmıştır" & vbLf & _
"TAMAM Butonunu tıkladıktan sonra lütfen bekleyiniz", vbInformation
Application.Calculation = xlCalculationAutomatic
End Sub

2) Sorum için kullandığım kodlar

Sub Güncelle()
Sheets("Formüller").Range("FK2:FK61").Copy
Range("E5").PasteSpecial xlPasteValues
For i = 5 To 55
If Cells(i, "E") <> "" Then
For j = 2 To 10
Cells(i, 2) = Range("B3")
Cells(i, 3) = Range("C3")
Cells(i, 6) = Range("F3")
Cells(i, 7) = Range("G3")
Cells(i, 8) = Range("H3")
Cells(i, 9) = Range("I3")
Cells(i, 10) = Range("J3")
Range("L5").Select
Next
End If
Next
End Sub

 

[Emir Hüseyin Çoban]

. . .

1.Kısım için mavi satırları ilave ederek deneyiniz.

    For i = 5 To 55
  [COLOR="blue"]      If s1.Cells(i, "K") <> "X" Then[/COLOR]
            s2.Cells(sonsatir, 6) = s1.Cells(i, 4)
            s2.Cells(sonsatir, 7) = s1.Cells(i, 5)
            s2.Cells(sonsatir, 11) = s1.Cells(i, 9)
            s2.Cells(sonsatir, 2) = s1.Cells(i, 2)
            s2.Cells(sonsatir, 8) = s1.Cells(i, 6)
            s2.Cells(sonsatir, 9) = s1.Cells(i, 7)
            s2.Cells(sonsatir, 12) = s1.Cells(i, 10)
            s2.Cells(sonsatir, 10) = s1.Cells(i, 9)
            s2.Cells(sonsatir, 5) = s1.Cells(i, 3)
            sonsatir = sonsatir + 1
[COLOR="Blue"]        End If[/COLOR]
    Next i

. . .

 

[Emir Hüseyin Çoban]

. . .

2.Kısım için

Sub Güncelle()
  [COLOR="Blue"]  Application.ScreenUpdating = False[/COLOR]

  [COLOR="Green"]' Kodlarınız...[/COLOR]

   [COLOR="blue"] 
    Application.CutCopyMode = False
    Application.ScreenUpdating = True[/COLOR]
End Sub

. . .