Limite ulaşıncaya kadar topla ve sonrasını sıfırla

[mühendis^^]

İyi akşamlar Herkese ;
1. satırda farklı aylara ait ödemeler var N1 hücresinde ki limite ulaşıncaya kadar sırası ile toplayıp tam limite ulaşan hücreyi üzerinde düzeltip geri kalan hücrelere 0,00 yazacak makro kodu konusunda yardıma ihtiyacım var.1 satır da olan durum 2. satır da olması gereken durumu izah etmeye çalıştım.ilgilenen herkese teşekkür ediyorum.

 

[Haluk]

Şöyle bir şey olabilir ....

Sub Test()
    Dim i As Integer
    Dim totalAmount As Currency, tempTotal As Currency
    Dim mySum As Currency
    
    Range("A2:H2") = 0
    i = 0
    totalAmount = Range("N1")
    
    Do While mySum <= totalAmount
        i = i + 1
        mySum = mySum + Cells(1, i)
        If mySum < totalAmount Then
            tempTotal = tempTotal + Cells(1, i)
            Cells(2, i) = Cells(1, i)
        Else
            Cells(2, i) = totalAmount - tempTotal
        End If
    Loop
End Sub

.

 

[Ömer BARAN]

Ben de hazırlamıştım göndereyim dedim.
.

Sub HESAPLA()
lim = [N1]: ilk = [A1]
If ilk > lim Then
    [A1] = lim: Range("B1:H1") = 0: Exit Sub
End If
lim = lim - [A1]
For sut = 2 To 8
    If lim >= Cells(1, sut) Then
        lim = lim - Cells(1, sut)
    Else
        Cells(1, sut) = lim: lim = 0
        If sut < 8 Then Range(Cells(1, sut + 1), Cells(1, 8)) = 0
    End If
Next
End Sub

 

[mühendis^^]

Haluk Bey ve Ömer Bey iki kodu da denedim ve olumlu sonuç alıyorum. ilginiz için teşekkür ederim iyi ki varsınız.
Sorun Çözülmüştür.

 

[Ömer BARAN]

Eyvallah, sağlıcakla.

 

[turist]

Deneyin.

Sub ToplaSifirla()
If WorksheetFunction.Sum(Range("A1:H1")) < Range("N1") Then
MsgBox "Sayıların toplamı " & Range("N1") & " değerinden küçüktür"
Exit Sub
End If
For i = 1 To 8
If Cells(1, i) >= Range("N1") Then
Cells(1, i) = Range("N1")
Range("B1:H1") = 0
Exit For
Else
toplam = toplam + Cells(1, i)
If toplam + Cells(1, i + 1) >= Range("N1") Then
Cells(1, i + 1) = Range("N1") - toplam
Range(Cells(1, i + 2), Cells(1, 8)) = 0
Exit For
End If
End If
Next i
End Sub

 

[mühendis^^]

Sayın turist sizin gönderdiğiniz kodda istenen sonucu vermektedir. Teşekkür ederim.

 

[turist]

Sayın turist sizin gönderdiğiniz kodda istenen sonucu vermektedir. Teşekkür ederim.

Sağolun.
Not:Sayıların toplamının N1 hücresinden küçük olma koşulunu test edebilrsiniz.

 

[mühendis^^]

Evet denedim ilave bir kontrol olmuş , makro gayet düzgün çalışıyor , sağlıcakla kalın.

 

[turist]

Sağolun, siz de sağlıcakla kalınız.