Eldeki paraya gore odeme paylastirma

[canburak]

Merhabalar, ekdeki dosyada anlatigim makroyu nasil yapa biliriz acaba mumkunati varmi, bi yardimci ola bilirmsiniz , bir nevi odem plani gibi bir tablo olmasi gerekiyor
Saygilar,

 

[Ömer BARAN]

Merhaba.

Formül ile çözüm isterseniz aşağıdaki formül sonuç verir.
Formül kısaltılabilir sanırım ama önemli olan sonuç almak derseniz, şimdilik aşağıdaki formülü kullanabilirsiniz.
Formülü E4 hücresine uygulayın ve aşağı doğru kopyalayın.
.

=EĞER(YADA(B4="kapali";ETOPLA($B$4:$B$19;"kapali";$D$4:$D$19)+ETOPLA($B$3:B4;"<>kapali";$D$3:D4)<$E$1);D4;EĞER(ETOPLA($B$3:B3;"<>kapali";$E$3:E3)+ETOPLA($B$4:$B$19;"kapali";$D$4:$D$19)<$E$1;$E$1-ETOPLA($B$4:$B$19;"kapali";$D$4:$D$19)-ETOPLA($B$3:B3;"<>kapali";$D$3:D3);""))

 

[canburak]

Merhaba.

Formül ile çözüm isterseniz aşağıdaki formül sonuç verir.
Formül kısaltılabilir sanırım ama önemli olan sonuç almak derseniz, şimdilik aşağıdaki formülü kullanabilirsiniz.
Formülü E4 hücresine uygulayın ve aşağı doğru kopyalayın.
.

=[COLOR="red"]EĞER[/COLOR](B4="kapali";D4;[COLOR="red"]EĞER[/COLOR]([COLOR="red"]ETOPLA[/COLOR]($B$4:$B$19;"kapali";$D$4:$D$19)+[COLOR="red"]ETOPLA[/COLOR]($B$3:B4;"<>kapali";$D$3:D4)<$E$1;D4;[COLOR="red"]EĞER[/COLOR]([COLOR="red"]ETOPLA[/COLOR]($B$3:B3;"<>kapali";$E$3:E3)+[COLOR="red"]ETOPLA[/COLOR]($B$4:$B$19;"kapali";$D$4:$D$19)<$E$1;$E$1-[COLOR="red"]ETOPLA[/COLOR]($B$4:$B$19;"kapali";$D$4:$D$19)-[COLOR="Red"]ETOPLA[/COLOR]($B$3:B3;"<>kapali";$D$3:D3);"")))

Ustat elina saglik bunu makroda yapa bilirmiyiz acaba ?

 

[Ömer BARAN]

Tekrar merhaba.

Önceki cevabımdaki gereksiz bir EĞER işlevini kaldırarak formülü biraz kısalttım.
(sayfayı yenileyerek önceki cevabımı kontrol ediniz)

Makro çözümü ise aşağıda.

Sub CANBURAK()
son = Cells(Rows.Count, "A").End(3).Row: hedef = [E1]
If Cells(Rows.Count, "E").End(3).Row > 4 Then Range("E4:E" & son).ClearContents
ktop = WorksheetFunction.SumIf(Range("B4:B" & son), "kapali", Range("D4:D" & son))
For sat = 4 To son
dtop = WorksheetFunction.SumIf(Range("B3:B" & sat), "<>kapali", Range("D3:D" & sat))
etop = WorksheetFunction.SumIf(Range("B3:B" & sat - 1), "<>kapali", Range("E3:E" & sat - 1))
    If Cells(sat, "B") = "kapali" Or ktop + dtop < hedef Then
        Cells(sat, "E") = Cells(sat, "D")
    ElseIf ktop + etop < hedef Then
        Cells(sat, "E") = hedef - ktop - etop
    End If
Next
MsgBox "İşlem tamamlandı.", vbInformation, "..::.. Ömer BARAN ..::.."
End Sub

 

[canburak]

Tekrar merhaba.

Önceki cevabımdaki gereksiz bir EĞER işlevini kaldırarak formülü biraz kısalttım.
(sayfayı yenileyerek önceki cevabımı kontrol ediniz)

Makro çözümü ise aşağıda.

[B][COLOR="Blue"]Sub CANBURAK()[/COLOR][/B]
[B]son[/B] = Cells(Rows.Count, "A").End(3).Row: [B][COLOR="Red"]hedef[/COLOR][/B] = [E1]
If Cells(Rows.Count, "E").End(3).Row > 4 Then Range("E4:E" & [B]son[/B]).ClearContents
[B]ktop[/B] = WorksheetFunction.SumIf(Range("B4:B" & [B]son[/B]), "kapali", Range("D4:D" & [B]son[/B]))
For sat = 4 To [B]son[/B]
[B][COLOR="DarkOrange"]dtop[/COLOR][/B] = WorksheetFunction.SumIf(Range("B3:B" & sat), "<>kapali", Range("D3:D" & sat))
[B][COLOR="SeaGreen"]etop[/COLOR][/B] = WorksheetFunction.SumIf(Range("B3:B" & sat - 1), "<>kapali", Range("E3:E" & sat - 1))
    If Cells(sat, "B") = "kapali" Or [B]ktop[/B] + [B][COLOR="DarkOrange"]dtop[/COLOR][/B] < [B][COLOR="Red"]hedef[/COLOR][/B] Then
        Cells(sat, "E") = Cells(sat, "D")
    ElseIf [B]ktop[/B] + [B][COLOR="SeaGreen"]etop[/COLOR][/B] < [B][COLOR="Red"]hedef[/COLOR][/B] Then
        Cells(sat, "E") = [B][COLOR="Red"]hedef[/COLOR][/B] - [B]ktop[/B] - [B][COLOR="SeaGreen"]etop[/COLOR][/B]
    End If
Next
MsgBox "İşlem tamamlandı.", vbInformation, "..::.. Ömer BARAN ..::.."
[B][COLOR="blue"]End Sub[/COLOR][/B]

Sagol ustat leine emegine saglik cok guzel olmus Allah razi olsun Hepinizden

 

[canburak]

Tekrar merhaba.

Önceki cevabımdaki gereksiz bir EĞER işlevini kaldırarak formülü biraz kısalttım.
(sayfayı yenileyerek önceki cevabımı kontrol ediniz)

Makro çözümü ise aşağıda.

Sub CANBURAK()
son = Cells(Rows.Count, "A").End(3).Row: hedef = [E1]
If Cells(Rows.Count, "E").End(3).Row > 4 Then Range("E4:E" & son).ClearContents
ktop = WorksheetFunction.SumIf(Range("B4:B" & son), "kapali", Range("D4:D" & son))
For sat = 4 To son
dtop = WorksheetFunction.SumIf(Range("B3:B" & sat), "<>kapali", Range("D3:D" & sat))
etop = WorksheetFunction.SumIf(Range("B3:B" & sat - 1), "<>kapali", Range("E3:E" & sat - 1))
    If Cells(sat, "B") = "kapali" Or ktop + dtop < hedef Then
        Cells(sat, "E") = Cells(sat, "D")
    ElseIf ktop + etop < hedef Then
        Cells(sat, "E") = hedef - ktop - etop
    End If
Next
MsgBox "İşlem tamamlandı.", vbInformation, "..::.. Ömer BARAN ..::.."
End Sub

Tekrar Merhaba Hocam bu insallah iyisinizdir, onceden ayarladiginiz bu usteki makroyu sadece kapali olanlara nasil uyarlaya biliriz , Dagitimi sadece kapali ise dagitmasi lazim bos yada baska bir sey yaziyorsa onlara birsey dagitmayacak

Simdiden cok tesekkurler yardimlariniz icin.

 

[Saban Sertkaya]

Merhabalar,
Aradan 3 yıldan fazla bir zaman geçmiş.
Altın üye olmadığımdan dosyanızı indirip içeriğini göremiyorum ama, Ömer Bey'in kodlamasındaki aşağıdaki ifadeleri değiştirerek bir dener misiniz.

<> eşitsizlikleri = ile değiştirerek bir dener misiniz ?

 

[veyselemre]

Tekrar Merhaba Hocam bu insallah iyisinizdir, onceden ayarladiginiz bu usteki makroyu sadece kapali olanlara nasil uyarlaya biliriz , Dagitimi sadece kapali ise dagitmasi lazim bos yada baska bir sey yaziyorsa onlara birsey dagitmayacak

Simdiden cok tesekkurler yardimlariniz icin.

Sub CANBURAK()
    son = Cells(Rows.Count, "A").End(3).Row: hedef = [E1]
    If Cells(Rows.Count, "E").End(3).Row > 4 Then Range("E4:E" & son).ClearContents

    For sat = 4 To son
        If Cells(sat, "B") = "kapali" Then
            If hedef >= Cells(sat, "D") Then
                Cells(sat, "E") = Cells(sat, "D")
                hedef = hedef - Cells(sat, "E")
            Else
                Cells(sat, "E") = hedef
                Exit For
            End If
        End If
    Next
    MsgBox "İşlem tamamlandı.", vbInformation, "..::.. Ömer BARAN ..::.."
End Sub

 

[canburak]

Merhaba Ustat , cok guzel olmus elinize saglik, buna ilave olarak hedef hucre, kapali yazan hucreler den fazla ise tutar fazla islemi yapamazsiniz diye mesaj ekleye bilirmiyiz.

Tesekkurler

 

[veyselemre]

Sub CANBURAK()
    son = Cells(Rows.Count, "A").End(3).Row: hedef = [E1]
    If Cells(Rows.Count, "E").End(3).Row > 4 Then Range("E4:E" & son).ClearContents
    ktop = WorksheetFunction.SumIf(Range("B4:B" & son), "kapali", Range("D4:D" & son))
    If hedef > ktop Then
        MsgBox "hedef hucre, kapali yazan hucreler den fazla.", vbInformation, "..::.. Ömer BARAN ..::.."
        Exit Sub
    End If
    For sat = 4 To son
        If Cells(sat, "B") = "kapali" Then
            If hedef >= Cells(sat, "D") Then
                Cells(sat, "E") = Cells(sat, "D")
                hedef = hedef - Cells(sat, "E")
            Else
                Cells(sat, "E") = hedef
                Exit For
            End If
        End If
    Next
    MsgBox "İşlem tamamlandı.", vbInformation, "..::.. Ömer BARAN ..::.."
End Sub

 

[canburak]

Eyvallay hocam elinize saglik cok iyi calisiyor, Eger fazla olmayacak isem, birsey daha isteyecektim bu makro ile ilgili dagitim tamamlandiktan sonra islem gormeyen satirlari sildire bilirmiyiz , Sanirim E sutununda bos olanlari silersek sadece dagitim yapilan satirlar kalir
Tesekkurler.