Alt yandaki Hücre Değerine Göre Hücre değeri bir alta kopyala

[cocoa35]

Merhaba üstatlar, Ekli örnek dosyada B6,C6 Hücrelerine rakkam girildiğinde E5 Hücresi E6'ya otomatik kopyalama yapsın ve bu işlem gri satırlar eklendikçe devam etsin istiyorum bu konuda yardımcı olrmusunuz.

 

[dEdE]

Merhaba,
Sayfanın kod bölümüne yapıştırarak dener misiniz?
Öneri: Bir üst satırı kopyalamak yerine kod ile B ve C sütunlarının toplamını yazmak daha iyi olmaz mı?

Private Sub Worksheet_Change(ByVal Target As Range)
    ss = Sayfa1.Cells(Rows.Count, "C").End(3).Row
    If Intersect(Target, Range("B6:C" & ss)) Is Nothing Then Exit Sub
    If Range("B" & Target.Row) = "" Or Range("C" & Target.Row) = "" Then Exit Sub
    If IsNumeric(Range("B" & Target.Row)) And IsNumeric(Range("C" & Target.Row)) Then
        Cells(Target.Row - 1, 5).Copy Cells(Target.Row, 5)
    Else
        MsgBox "Lütfen sayısal bir değer giriniz.", vbCritical, "DİKKAT !"
    End If
End Sub

 

[veyselemre]

Bu iş için makroya gerek yok, B-C hücrelerine veri girip e hücresine geçip Ctrl-D ile üst hücreyi kopyalayın. Bu işlemi 4-5 kez uyguladıktan sonra, excel e hücresini otomatik olarak veri girdikçe aşağıya kopyalayacaktır.

 

[cocoa35]

Private Sub Worksheet_Change(ByVal Target As Range) ss = Sayfa1.Cells(Rows.Count, "C").End(3).Row If Intersect(Target, Range("B6:C" & ss)) Is Nothing Then Exit Sub If Range("B" & Target.Row) = "" Or Range("C" & Target.Row) = "" Then Exit Sub If IsNumeric(Range("B" & Target.Row)) And IsNumeric(Range("C" & Target.Row)) Then Cells(Target.Row - 1, 5).Copy Cells(Target.Row, 5) Else MsgBox "Lütfen sayısal bir değer giriniz.", vbCritical, "DİKKAT !" End If End Sub

Çok teşekkürler dede gayet istediğim şekilde olmuş

 

[cocoa35]

Sayın Dede Merhaba, Öncelikle ilginiz için teşekkür ederim örnek dosya tam istediğim gibi olmuş ancak ben bu çalışmayı kendi dosyama adepte edemedim bu benim hatam, keşke başta bu dosyayı gönderseydim, orjinal dosyada gri satırlarda tarih bulunuyor işlem olarakda V sütununda iki tarh arasındaki farkı alıyor. sizden ricam esas dosyaya uyarlama yapabilirmisiniz

Bu iş için makroya gerek yok, B-C hücrelerine veri girip e hücresine geçip Ctrl-D ile üst hücreyi kopyalayın. Bu işlemi 4-5 kez uyguladıktan sonra, excel e hücresini otomatik olarak veri girdikçe aşağıya kopyalayacaktır.

 

[dEdE]

Merhaba,
Aşağıdaki kodu Rezervasyon sayfasının kod bölümüne yapıştırarak deneyiniz.
İlk mesajdaki önerimi tekrarlıyorum. Sizin istediğiniz şekilde olunca sürekli formülleri çoğaltıyoruz. Bu da uzun vadede dosya boyutunuzun büyümesine ve excelin yavaşlamasına neden olacaktır. Kod içinde gerekli açıklamayı yaptım. istediğinizi kullanabilirsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    ss = Sheets("Rezervasyon").Cells(Rows.Count, "I").End(3).Row
    If Intersect(Target, Range("H6:I" & ss)) Is Nothing Then Exit Sub
    If Range("H" & Target.Row) = "" Or Range("I" & Target.Row) = "" Then Exit Sub
    If IsDate(Range("H" & Target.Row)) And IsDate(Range("I" & Target.Row)) Then
        Cells(Target.Row - 1, "V").Copy Cells(Target.Row, "V") 'Formülü kopyalar
        'Cells(Target.Row, "V") = Cells(Target.Row, "I") - Cells(Target.Row, "H")' Formülle aynı işlemi yapar sonucu yazar
    Else
        MsgBox "Lütfen geçerli bir tarih giriniz." & vbCrLf & vbCrLf & _
            "Örneğin: " & Date & " gibi", vbCritical, "DİKKAT !"
    End If
End Sub

 

[cocoa35]

Merhaba,
Aşağıdaki kodu Rezervasyon sayfasının kod bölümüne yapıştırarak deneyiniz.
İlk mesajdaki önerimi tekrarlıyorum. Sizin istediğiniz şekilde olunca sürekli formülleri çoğaltıyoruz. Bu da uzun vadede dosya boyutunuzun büyümesine ve excelin yavaşlamasına neden olacaktır. Kod içinde gerekli açıklamayı yaptım. istediğinizi kullanabilirsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    ss = Sheets("Rezervasyon").Cells(Rows.Count, "I").End(3).Row
    If Intersect(Target, Range("H6:I" & ss)) Is Nothing Then Exit Sub
    If Range("H" & Target.Row) = "" Or Range("I" & Target.Row) = "" Then Exit Sub
    If IsDate(Range("H" & Target.Row)) And IsDate(Range("I" & Target.Row)) Then
        Cells(Target.Row - 1, "V").Copy Cells(Target.Row, "V") 'Formülü kopyalar
        'Cells(Target.Row, "V") = Cells(Target.Row, "I") - Cells(Target.Row, "H")' Formülle aynı işlemi yapar sonucu yazar
    Else
        MsgBox "Lütfen geçerli bir tarih giriniz." & vbCrLf & vbCrLf & _
            "Örneğin: " & Date & " gibi", vbCritical, "DİKKAT !"
    End If
End Sub

[/QUOTE
Teşekkürler gayet güzel oldu şimdi