Formüllü Son Satırın Bir Alt Satıra Kopyalanması

[Kenantu]

Merhabalar Dostlarım

Elimde bir excel dosyası var ve ben bu dosyaya userform aracılığı ile bilgi giriyorum A sütunu tarih , B sütunu açıklama , C sütunu Borç ve D sütunu Alacak sütunları . Userform ile bunlara bilgileri giriyorum. E sütunu Borç Bakiye F sütunu Alacak Bakiye ve G sütunundada bakiye hesabı için formüllerim var. Aşağıdaki makro ile bilgileri girmeden önce boş olan ilk satırın tespit edilmesi ve satırın seçilerek bir alt satıra kopyalanması ve daha sonra aşağıdaki makronun devraye girmesi için nasıl bir makro yazmalıyım veya aşağıdaki satırların neresine ne gibi satırlar eklemeliyim

Private Sub cmdkaydet_Click()
Range("A1").Select
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
ActiveCell.Rows.Copy
ActiveCell.Offset(2, 0).PasteSpecial

Loop


ActiveCell.Offset(0, 0).Value = tarih.Value
ActiveCell.Offset(0, 1).Value = aciklama.Value
ActiveCell.Offset(0, 2).Value = borc.Value
ActiveCell.Offset(0, 3).Value = alacak.Value

End Sub

Şİmdiden herkeze çok çok teşekkür ederim.

 

[Kenantu]

Herkezden özür dilerim makroda bir hata var denemelerimdeki bazı satırları unutmuşum düzeltiyorum

Private Sub cmdkaydet_Click()
Range("A1").Select
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select

Loop


ActiveCell.Offset(0, 0).Value = tarih.Value
ActiveCell.Offset(0, 1).Value = aciklama.Value
ActiveCell.Offset(0, 2).Value = borc.Value
ActiveCell.Offset(0, 3).Value = alacak.Value

End Sub

 

[Korhan Ayhan]

Selamlar,

Örnek bir dosya eklermisiniz.

 

[Kenantu]

mesaj ekinde dosya mevcuttur.

 

[Korhan Ayhan]

Selamlar,

Örnek dosyanızdaki kaydet butonunda kullandığınız kodu aşağıdaki ile değiştirip denermisiniz. Ayrıca eğer veri tabanınızda aralarda boş satır yoksa DO-LOOP döngüsünü kullanmadan direkt olarak son boş satıra verilerinizi kaydedebilirsiniz. Bunun için ikinci kodu kullanabilirsiniz. Verileriniz arttıkça aradaki hız farkını gözlemleyebilirsiniz.

1. Kod ;

Private Sub cmdkaydet_Click()
    Range("A1").Select
    ActiveCell.Offset(1, 0).Select
    Do While Not IsEmpty(ActiveCell)
    ActiveCell.Offset(1, 0).Select
    Loop
    
    SATIR = ActiveCell.Row
    Range(Cells(SATIR, "E"), Cells(SATIR, "G")).FormulaR1C1 = Range(Cells(SATIR - 1, "E"), Cells(SATIR - 1, "G")).FormulaR1C1
    ActiveCell.Offset(0, 0).Value = tarih.Value
    ActiveCell.Offset(0, 1).Value = aciklama.Value
    ActiveCell.Offset(0, 2).Value = borc.Value
    ActiveCell.Offset(0, 3).Value = alacak.Value
End Sub

2. Kod ;

Private Sub cmdkaydet_Click()
    SATIR = [A65536].End(3).Row + 1
    Range(Cells(SATIR, "E"), Cells(SATIR, "G")).FormulaR1C1 = Range(Cells(SATIR - 1, "E"), Cells(SATIR - 1, "G")).FormulaR1C1
    Cells(SATIR, 1) = tarih.Value
    Cells(SATIR, 2) = aciklama.Value
    Cells(SATIR, 3) = borc.Value
    Cells(SATIR, 4) = alacak.Value
End Sub

 

[Kenantu]

Merhabalar
Kotları denedim ama Range satırında hata veriyor ve çalışmıyor dostum. Neden çalışmıyor bende anlamadım ama düşündüğün çözüm güzeldi. Yinede çok teşekkürler. Ama maalesef çalışmadı dostum

 

[Korhan Ayhan]

Selamlar,

Ekte örnek dosyanızda gerekli düzenlemeleri yaptım. İncelermisiniz. Test ettim çalışıyor. Umarım faydası olur.

 

[Kenantu]

Dostum Tekrardan Merhabalar

Dosyayı aldım denedim ama bende yine sorun yaptı hemde yine Range yani satır seçme satırında inatla hata veriyor
Run-time 1004
Application-defined or object-defined error diye bir hata veriyor

 

[Korhan Ayhan]

Selamlar,

En son eklediğim dosyadamı hata mesajı alıyorsunuz. Yoksa kendi dosyanıza uyguladığınızdamı ?

 

[Kenantu]

evet sizden gelen son dosyada calışmıyor neden çalışmadığınıda anlayamadım

 

[Korhan Ayhan]

Selamlar,

İlginç defalarca denedim bende bir sorun görünmüyor. Birde aşağıdaki şekilde denermisiniz.

Private Sub cmdkaydet_Click()
    Dim SATIR As Long
    SATIR = [A65536].End(3).Row + 1
    Range(Cells(SATIR, "E"), Cells(SATIR, "G")).FormulaR1C1 = Range(Cells(SATIR - 1, "E"), Cells(SATIR - 1, "G")).FormulaR1C1
    Cells(SATIR, 1) = tarih.Value
    Cells(SATIR, 2) = aciklama.Value
    Cells(SATIR, 3) = borc.Value
    Cells(SATIR, 4) = alacak.Value
End Sub

 

[Kenantu]

Sayın Cost
İlginiz için gönülden teşekkür ederim ama maalesef aynı satırda hata veriyor ne yaptıysam olmuyor ilginç sizi çok yorduğumun farkındayım ama ne yapayım olmuyor başka bir çözüm bulmaya çalışacağım sizin aklınıza başka bir çözüm geliyorsa bana bildirirseniz çok sevinirim sizide daha fazla uğraştırmak istemiyorum.
Tekrardan çok teşekkür ederim

 

[Kenantu]

Yukarıda yapmaya çalıştığım satır kopyalama olayını halledemedim bir türlü bunun üzerine formülleri makro ile halletmeye çalıştım ve aşağıdaki makro yazılımı benim işimi gördü fakat hem uzun hemde ağır. Bu yazılımı hızlandırmak ve kısaltmak mümkünmüdür. Bu konuda yardımcı olursanız çok sevinirim.

Teşekkürler

Private Sub cmdkaydet_Click()
Range("A1").Select
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(0, 0).Value = tarih.Value
ActiveCell.Offset(0, 1).Value = aciklama.Value
ActiveCell.Offset(0, 2).Value = borc.Value
ActiveCell.Offset(0, 3).Value = alacak.Value

Dim A As Single
Dim B As Single

A = Val(borc.Value) - Val(alacak.Value)
B = (Val(ActiveCell.Offset(-1, 4).Value) - Val(ActiveCell.Offset(-1, 5).Value))

If A > 0 And B >= 0 Then
ActiveCell.Offset(0, 4).Value = (A + B)
ActiveCell.Offset(0, 5).Value = 0
ElseIf A < 0 And B <= 0 Then
ActiveCell.Offset(0, 5).Value = (A + B) * (-1)
ActiveCell.Offset(0, 4).Value = 0
ElseIf A > 0 And B <= 0 And A < B * (-1) Then
ActiveCell.Offset(0, 5).Value = (A + B) * (-1)
ActiveCell.Offset(0, 4).Value = 0
ElseIf A > 0 And B <= 0 And A > B * (-1) Then
ActiveCell.Offset(0, 4).Value = (A + B)
ActiveCell.Offset(0, 5).Value = 0
ElseIf A < 0 And B >= 0 And (-1) * A < B Then
ActiveCell.Offset(0, 4).Value = (A + B)
ActiveCell.Offset(0, 5).Value = 0
ElseIf A < 0 And B >= 0 And (-1) * A > B Then
ActiveCell.Offset(0, 5).Value = (A + B) * (-1)
ActiveCell.Offset(0, 4).Value = 0



MsgBox "KAYIT İŞLEMİNİZ TAMAMLANMIŞTIR"
End If
End Sub