• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Eldeki paraya gore odeme paylastirma

C

canburak

Katılım
30 Kasım 2011
Mesajlar
205
Excel Vers. ve Dili
Ofis 2016 Tr 64 Bit , Turkce
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,
 

Ekli dosyalar

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.
.
Kod: 
=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);""))
 
Son düzenleme:
Ömer BARAN' Alıntı:
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.
.
Kod: 
=[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);"")))
Genişletmek için tıkla ...

Ustat elina saglik bunu makroda yapa bilirmiyiz acaba ?
 
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.

Kod: 
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
 
Son düzenleme:
Ömer BARAN' Alıntı:
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.

Kod: 
[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]
Genişletmek için tıkla ...

Sagol ustat leine emegine saglik cok guzel olmus Allah razi olsun Hepinizden
 
Ömer BARAN' Alıntı:
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.

Kod: 
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
Genişletmek için tıkla ...
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.
 
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 ?
 
canburak' Alıntı:
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.
Genişletmek için tıkla ...
Kod: 
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
 
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
 
Kod: 
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
 
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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst