Rakamları eşit dağıtmak

[muratgunay48]

Arkadaşlar, dosyada kırmızı bölgede olan fiyatlar YENİ FİYAT onları elle değiştirdiğim zaman.
Örneğin FİYAT 1 toplamı ₺151,19 tutmuş. YENİ FİYAT'ta bir ürün değerini değiştirince (mesela ilk ürünü ₺3,5 yaptım) FİYAT 1'de ₺5,5 bu aradaki -2 lirayı FİYAT 2'ye eşit olarak dağıtacak. FİYAT 2 toplamı yine ₺151,19 olacak. Eksi artı fark etmez, fiyat artabilir de. Mesele eşit olarak dağıtacak.
Yardımcı olan arkadaşlara şimdiden teşekkür ederim.

 

[YUSUF44]

Aşağıdaki kodları sayfanızın kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) yapıştırıp deneyiniz. I2:I15 aralığında değişiklik olduğunda çalışır:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [I2:I15]) Is Nothing Then Exit Sub
fiyat = [F16]
a = Target.Row
eski = Cells(a, "E").Value
fark = Target - eski
ek = Round(fark / 14, 2) * (-1)
For i = 2 To 15
    Cells(i, "F") = Cells(i, "F") + ek
Next
[F2] = [F2] - ([F16] - fiyat)
End Sub

 

[muratgunay48]

Aşağıdaki kodları sayfanızın kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) yapıştırıp deneyiniz. I2:I15 aralığında değişiklik olduğunda çalışır:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [I2:I15]) Is Nothing Then Exit Sub
fiyat = [F16]
a = Target.Row
eski = Cells(a, "E").Value
fark = Target - eski
ek = Round(fark / 14, 2) * (-1)
For i = 2 To 15
    Cells(i, "F") = Cells(i, "F") + ek
Next
[F2] = [F2] - ([F16] - fiyat)
End Sub

Hocam emeğinize sağlık.