Arşivlemede hata

[ormann]

ekteki arşivleme dosyasında veri girişi sayfasından verileri kayıt sayfasından çağırıyorum.Arşivleme butonuna bastığımda veriler kayıt sayfasından çıkarılarak arşiv sayfasına gönderiliyo.Buraya kadar hiçbir sorun yok .Sorun:Bazen kayıt sayfasında bazı satırlarda hücrelerde veri oluyo,bazı hücrelerde veri olmuyo.Kayıttan alınarak arşive gönderilen satırdaki tüm veriler kendi satırına gönderilmesi lazımken arşivde bir üst satırda bazı hücrelerde veri yoksa direk o hücreye kayıt yapıyo.kayıtlarda kayma ve karışıklık yaşanıy kadar uğraşmama rağmen bir türlü başaramadım.siz değerli hocalarımdan yardım bekliyorum.Dosyaların şifresi:12345

Not:Genelde verigirişinde f17:m34 hücrelerinde not varsa arşivde s hücresinde bir üst satırda not olmayan satıra kopyalanıyo


Option Explicit



Sub Arsive_Gonder()
Dim ara As Range
Dim i As Integer
Dim x As Integer
Dim y As Integer
Dim say As Integer
Sheets("ARŞİV").Unprotect "12345"
Sheets("VERİ GİRİŞİ").Unprotect "12345"
Sheets("KAYIT").Unprotect "12345"
If Sheets("VERİ GİRİŞİ").Range("D5").Value = "" Then

MsgBox "ARŞİVE GÖNDERMEDEN ÖNCE LÜTFEN VERİYİ ÇAĞIRINIZ", vbInformation
Range("a1").Select
Exit Sub
Else
If MsgBox("VERİLERİNİZ ARŞİVE GÖNDERİLSİN Mİ ?", vbExclamation + vbYesNo, "") = vbYes Then
For i = 1 To 1000
If Worksheets("ARŞİV").Cells(i, "a").Value = Worksheets("VERİ GİRİŞİ").Range("d6").Value Then
MsgBox "AYNI VERİDEN DAHA ÖNCE KAYIT EDİLMİŞ", vbInformation
Sheets("VERİ GİRİŞİ").Protect "12345"
Sheets("ARŞİV").Protect "12345"
Sheets("KAYIT").Protect "12345"
Exit Sub
End If
Next i
Application.ScreenUpdating = False
Sheets("ARŞİV").Select
If Range("b2").Value = "" Then
Sheets("VERİ GİRİŞİ").Select
Range("D522").Select
Selection.Copy
Sheets("ARŞİV").Select
Range("a2").Select
Selection.PasteSpecial Paste:=xlValues, Transpose:=True
Sheets("VERİ GİRİŞİ").Range("f17").Copy
Sheets("ARŞİV").Select
Range("s2").Select
Selection.PasteSpecial Paste:=xlValues
Range("t2").Value = Format(Now, "dd.mm.yyyy")
Application.CutCopyMode = False
MsgBox "VERİLERİNİZ ARŞİVE GÖNDERİLDİ", vbInformation
On Error GoTo 10
Set ara = Worksheets("KAYIT").Range("a2:a65536").Find(Worksheets("VERİ GİRİŞİ").Range("D5"))
ara.EntireRow.Delete
Sheets("KAYIT").Select
say = WorksheetFunction.CountA(Worksheets("KAYIT").Range("b1:b65536"))
For x = 1 To say - 1
Sheets("KAYIT").Cells(x + 1, "a").Value = x
Next x
10
Sheets("VERİ GİRİŞİ").Range("D522").Value = ""
Sheets("VERİ GİRİŞİ").Range("c3:h3").Value = ""
Sheets("VERİ GİRİŞİ").Range("f17").Value = ""
Sheets("VERİ GİRİŞİ").Select
Range("a1").Select
Sheets("VERİ GİRİŞİ").Protect "12345"
Sheets("ARŞİV").Protect "12345"
Sheets("KAYIT").Protect "12345"
Else
Sheets("VERİ GİRİŞİ").Select
Range("D522").Select
Selection.Copy
Sheets("ARŞİV").Select
[a65536].End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues, Transpose:=True
Sheets("VERİ GİRİŞİ").Range("f17").Copy
Sheets("ARŞİV").Select
[s65536].End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues
[t65536].End(xlUp).Offset(1, 0).Select
ActiveCell.Value = Format(Now, "dd.mm.yyyy")
Application.CutCopyMode = False

MsgBox "VERİLERİNİZ ARŞİVE GÖNDERİLDİ", vbInformation

On Error GoTo 20
Set ara = Worksheets("KAYIT").Range("a2:a65536").Find(Worksheets("VERİ GİRİŞİ").Range("D5"))
ara.EntireRow.Delete
Sheets("KAYIT").Select
say = WorksheetFunction.CountA(Worksheets("KAYIT").Range("b1:b65536"))
For y = 1 To say - 1
Sheets("KAYIT").Cells(y + 1, "a").Value = y
Next y
20
Sheets("VERİ GİRİŞİ").Range("D522").Value = ""
Sheets("VERİ GİRİŞİ").Range("c3:h3").Value = ""
Sheets("VERİ GİRİŞİ").Range("f17").Value = ""
Sheets("VERİ GİRİŞİ").Select
Range("A1").Select
Sheets("VERİ GİRİŞİ").Protect "12345"
Sheets("ARŞİV").Protect "12345"
Sheets("KAYIT").Protect "12345"
End If
End If
End If


End Sub

 

[ormann]

Sayın arkadaşlar yardımınıza ihtiyacım var

 

[ormann]

Sayın arkadaşlar 1.nolu mesajımdaki makroyu düzenlemeye yardımcı olurmusunuz ?Saygılar