Döngüsel Başvuru Hatası

[DeliBalta58]

Öncelikle herkesin yeni yılı kutlu olsun.
Sayfa1 de personel bilgilerim var. Personel sayısı artıp eksiliyor.

A Sütununda Sıra No
B Sütununda SOYADI Adı
C Sütununda Say2000i Numaraları
D Sütununda Genel / Trafik ayrımı var.

Sayfa2 ye D sütununda olan Genel ayrımına göre sıra ile tüm veriler aktarılacak
Sayfa3 ede Trafik alrımı olan bilgiler satır halinde kopyalanacak.

Daha önce bir uzmanım aşağıdaki kodlarla yardımcı oldu. Ancak neden olduğunu anlayamadım ama Döngüsel Başvuru hatası veriyor.İlginç olan kısım ise bu hatayı herzaman vermiyor. Aynı bilgisayar. Aynı kullanıcı. yapılan işlemler aynı ama bazen bu hatayı veriyor.

Ayrıca işlem bitene kadar Sayfalar arası geçiş yapılıyor.
Kodlar:

Sub aktar()
'================ Personel Genel / Trafik Ayrımı yapııyor  ===================
Sheets("Sayfa1").Select               'Sayfa1'i Seç
For x = 2 To [a65536].End(3).Row      'A sütununda Dolu Hücreleri Seç
If Cells(x, 4) = "Genel" Then          'Eğer Rsi X C si 4. Sütunda "Genel Yazıyor ise"
Range("a" & x & ":" & "d" & x).Copy    '
Sheets("Sayfa2").Select
sira = [a65536].End(3).Row + 1
Cells(sira, 1).PasteSpecial
Cells(sira, 1) = sira - 1
End If
Sheets("Sayfa1").Select
If Cells(x, 4) = "Trafik" Then
Range("a" & x & ":" & "d" & x).Copy
Sheets("Sayfa3").Select
sira = [a65536].End(3).Row + 1
Cells(sira, 1).PasteSpecial
Cells(sira, 1) = sira - 1
Sheets("Sayfa1").Select
End If
Next
End Sub

Bu kodları sayfalar arası geçiş yaptırmadan yeniden düzenleyebilirmiyiz acaba ?
Dosya ekte.

 

[Orion1]

Dosyanız ekte.

Sub aktar()
Dim syf As Worksheet
'================ Personel Genel / Trafik Ayrımı yapııyor  ===================
Sheets("Sayfa1").Select 'Sayfa1'i Seç
Application.ScreenUpdating = False
For x = 2 To [a65536].End(3).Row      'A sütununda Dolu Hücreleri Seç
If Cells(x, 4) = "Genel" Then Set syf = Sheets("Sayfa2") 'Eğer Rsi X C si 4. Sütunda "Genel Yazıyor ise"
If Cells(x, 4) = "Trafik" Then Set syf = Sheets("Sayfa3")
Range("a" & x & ":" & "d" & x).Copy    '
sira = syf.[a65536].End(3).Row + 1
If sira >= 65533 Then
    MsgBox "[ " & syf.Name & " ] isimli sayfada satır doldu." & vbLf _
    & "Bu sayfaya kayıt yapılmadı..!!", vbCritical, "UYARI"
    GoTo atla
End If
syf.Cells(sira, 1).PasteSpecial
syf.Cells(sira, 1) = sira - 1
atla:
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
Set syf = Nothing
MsgBox "Aktarma tamamlandı..!!", vbOKOnly + vbInformation, Application.UserName
End Sub

 

[DeliBalta58]

Elinize ve Emeğinize sağlık.

 

[Orion1]

Elinize ve Emeğinize sağlık.

Rica ederim.
İyi çalışmalar.