ActiveCell.Offset ile sayfaya veri aktarma sınırı

[emsey]

Saygıdeğer üstadlar.

aşağıdaki kod ile sayfa4'e yatay bir şekilde veri aktarıyorum. kodları bir butona ayarladım ve tıkladığımda aşağıdaki koda istinaden verileri sorunsuz bir şekilde son boş satıra atarak ilerliyorum. Benim istediğim ve yapmak istediğim şu şekilde. A1 hücresinde yazılı numara değişmediği taktirde aşağıdaki komut 35 satır sonra dursun. Örneğin A1 hücresinde 2350 sayısı yazıyor ve bu şekilde aşağıdaki kodlar ile 35 satır kayıt edebilsin, eğer A1 hücresi 2351 olursa tekrar 36. satırdan aşağıdaki kodlar ile kayıt edebilmeye devam edebilsin. Özetle A1 hücresindeki numara ile sadece 35 satır kayıt edebilsin istiyorum. Yardımcı olursanız beni mutlu edersiniz. İlginize şimdiden teşekkür eder, iyi çalışmalar dilerim.


Sub save2()

Application.ScreenUpdating = False

Dim cevap, MyString

cevap = MsgBox("Bilgileri Kayıt Etmek İstediğinizden Emin misiniz ?", vbYesNo + vbCritical + vbDefaultButton2, "Kayıt İşlemi", "", 1000)
If cevap = vbYes Then

Sheets("data").Select

Range("a2").Select

Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop



ActiveCell.Offset(0, 0).Value = Sayfa4.Range("B1").Value
ActiveCell.Offset(0, 1).Value = Sayfa4.Range("B2").Value
ActiveCell.Offset(0, 2).Value = Sayfa4.Range("D1").Value
ActiveCell.Offset(0, 3).Value = Sayfa4.Range("D2").Value
ActiveCell.Offset(0, 4).Value = Sayfa4.Range("B3").Value
ActiveCell.Offset(0, 5).Value = Sayfa4.Range("B5").Value
ActiveCell.Offset(0, 6).Value = Sayfa4.Range("B6").Value
ActiveCell.Offset(0, 7).Value = Sayfa4.Range("B7").Value
ActiveCell.Offset(0, 8).Value = Sayfa4.Range("B8").Value
ActiveCell.Offset(0, 9).Value = Sayfa4.Range("B9").Value
ActiveCell.Offset(0, 10).Value = Sayfa4.Range("B4").Value



Else

MsgBox "Kayıt İşlemi İptal Edildi!", vbOKOnly, "Dikkat !"


End If


End Sub

 

[Muzaffer Ali]

Merhaba.
Kodlarınızı aşağıdakiler ile değiştirin.

Sub save2()
    Dim Cevap As VbMsgBoxResult
    Dim BosSatir As Integer
    Cevap = MsgBox("Bilgileri Kayıt Etmek İstediğinizden Emin misiniz ?", vbYesNo + vbCritical + vbDefaultButton2, "Kayıt İşlemi", "", 1000)
    If Cevap = vbYes Then
        BosSatir = Sheets("data").Cells(Rows.Count, "A").End(xlUp).Row + 1
        KayitSay = 1 + KayitSay
        If KayitSay > 35 Then
            MsgBox "35 satırdan fazla kayıt yapamazsınız."
            Exit Sub
        End If
        With Worksheets("data")
            .Cells(BosSatir, "A").Value = Sayfa4.Range("B1").Value
            .Cells(BosSatir, "B").Value = Sayfa4.Range("B2").Value
            .Cells(BosSatir, "C").Value = Sayfa4.Range("D1").Value
            .Cells(BosSatir, "D").Value = Sayfa4.Range("D2").Value
            .Cells(BosSatir, "E").Value = Sayfa4.Range("B3").Value
            .Cells(BosSatir, "F").Value = Sayfa4.Range("B5").Value
            .Cells(BosSatir, "G").Value = Sayfa4.Range("B6").Value
            .Cells(BosSatir, "H").Value = Sayfa4.Range("B7").Value
            .Cells(BosSatir, "I").Value = Sayfa4.Range("B8").Value
            .Cells(BosSatir, "J").Value = Sayfa4.Range("B9").Value
            .Cells(BosSatir, "K").Value = Sayfa4.Range("B4").Value
        End With
    Else
        MsgBox "Kayıt İşlemi İptal Edildi!", vbOKOnly, "Dikkat !"
    End If
End Sub

Aşağıdaki kodu da kontrol edilecek A1 hücresinin bulunduğu sayfanın kod kısmına kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A1")) Is Nothing Then
        If OncekiDeger = "" Then OncekiDeger = Range("A1")
        If OncekiDeger <> Range("A1") Then
            KayitSay = 0
            OncekiDeger = Range("A1")
        End If
       
    End If
End Sub

Aşağıdakileri de herhangi bir modüle nin en üst satırına kopayalayın.

Public OncekiDeger As String
Public KayitSay As Integer

 

[emsey]

@dalgalikur üstadım ilgi ve emeğinize sağlık test ettim işime yaradı yalnız şimdi testleri yaparken bazı ihtiyaçlar gelişti örneğin sayfa4 gereksiz deneme kayıtları ile dolu bu kayıtları silip sayfa4 komple boşaltıyorum ve yeni kayıt yapmaya başladığımda boş olmasına rağmen hiç kayıt yok.
MsgBox "35 satırdan fazla kayıt yapamazsınız." çalışıyor.

Birde önceki kayıt atan Activecell formülünde, kayıt yapacağı sayfada süzme özelliği süzülü kalmışken bile en son dolu satıra atıyordu bu güzeldi. Şimdi değiştirdiğimiz .Cells(BosSatir, "A").Value = Sayfa4.Range("B1").Value komutları ile sayfa süzdeyken önceki verilerin üzerine yazarak daha önceki satırı değiştirip verilerin bozulmasına sebep oluyor. En son dolu satıra atmıyor. Bu hata ile süz'de kalan sayfadaki verileri bozabilir.

Son olarak bu ilave ihtiyaç oldu öngörüp yazmamıştım. A1 Hücresindeki numarayı farklı bir numara ile değiştirip yeni bir kayıt yaptıktan sonra tekrar eski numaraya döndüğümde kayıt yapmaya devam ediyorum. Yani sistemi kandırıp 35 satırdan fazla giriş yapabiliyorum. A1 hücresindeki numaraya daha sonrada ekleme yapmak istediğimde araya başka numaralı kayıt veya kayıtlar girmiş olsa dahi 35 satırda sınırlandırma imkanımız olabilir mi?

İlginiz için çok teşekkür ederim.

 

[Muzaffer Ali]

Dediğiniz şeyler yapılabilir/düzeltilebilir.
Şu an pek vaktim yok. Eğer ilgilenen olmazsa daha sonra müsait bir zamanımda ilgilenirim.

 

[emsey]

Çok makbule geçer şimdiden teşekkür ediyorum.

Dediğiniz şeyler yapılabilir/düzeltilebilir.
Şu an pek vaktim yok. Eğer ilgilenen olmazsa daha sonra müsait bir zamanımda ilgilenirim.

 

[Muzaffer Ali]

Bu arada siz de bir örnek dosya hazırlayıp paylaşın.

 

[emsey]

@dalgalikur örnek dosyayı ekte paylaşıyorum. Megabyt yüksek olduğu için rar yaptım.

 

[Muzaffer Ali]

Dosyanız ekte.

 

[emsey]

Allah razı olsun üstat tamda istediğim buydu emeğine yüreğine sağlık. Çok teşekkür ediyorum.

Dosyanız ekte.

 

[Muzaffer Ali]

Allah senden de razı olsun. Bil mukabele. Kolay gelsin.