• DİKKAT

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

Taksit planlamasının revize edilmesi hk.

K

kemal turan

Altın Üye
Katılım
10 Haziran 2011
Mesajlar
1,677
Excel Vers. ve Dili
Excel 2010 32 bit
Merhabalar,
taksitlerini taahhüt ettikleri gibi ödemeyen yarısını ödeyen müşterilerin ödeme planının revize edilmesine ihtiyacım var.
Ek dosyada açıkladım.Yardımlarınız için şimdiden teşekkür ederim.
Not Sayfanın kod bölümüne yazılacak olan makro ödenecek ile ödenen miktar arasında eşitsizlik olduğunda çalışacak.
Selametle kalınız.
 

Ekli dosyalar

Merhaba
Sayfanın kod bölümüne kopyalayın ve deneyin.
Kod: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Count = 1 Then
If Intersect(Target, Range("G2:G" & Rows.Count)) Is Nothing Then _
Application.EnableEvents = True: Exit Sub
If Target = Empty Then Application.EnableEvents = True: Exit Sub
If Cells(Target.Row, "F") > Target Then
Rows(Target.Row + 1).Insert shift:=xlDown
Cells(Target.Row + 1, "A") = Cells(Target.Row, "A")
Cells(Target.Row + 1, "B") = Cells(Target.Row, "B")
Cells(Target.Row + 1, "C") = Cells(Target.Row, "C")
Cells(Target.Row + 1, "D") = Cells(Target.Row, "D")
Cells(Target.Row + 1, "E") = Cells(Target.Row, "E")
Cells(Target.Row + 1, "F") = Cells(Target.Row, "F") - Target
Cells(Target.Row, "F") = Target
End If: End If
Application.EnableEvents = True
End Sub
 
Son düzenleme:
Sn.Asikral
Çok teşekkür ederim.
küçük bir işlem daha var.
Örnek, 1000 tl ödenecek tutara karşılık 500 tl ödeniyor ya.o satırdaki ödenecek olan 1000 tl.nin ödenen tutara eşit olması gerekiyor.
Bold olan tutarın 500 tl olması gerekiyor.
ödenecek ödenen
1000 500
500
 
kemal turan' Alıntı:
Sn.Asikral
Çok teşekkür ederim.
küçük bir işlem daha var.
Örnek, 1000 tl ödenecek tutara karşılık 500 tl ödeniyor ya.o satırdaki ödenecek olan 1000 tl.nin ödenen tutara eşit olması gerekiyor.
Bold olan tutarın 500 tl olması gerekiyor.
ödenecek ödenen
1000 500
500
Genişletmek için tıkla ...

Üstteki kodu güncelledim.
 
Merhaba Sn.asikral
Çok teşekkür ederim.Hakkınızı helal ediniz.
Selametle kalınız.
 
Sn.Asikral
Küçük bir sorunumuz var.
G sutununda bir ödemeyi sildiğimiz zaman makroyu durdurabilirmiyiz.
Ayrıca tüm satırı sildiğimiz zaman hata vermesini engelleyebilirmiyiz.
Teşekkürler
 
kemal turan' Alıntı:
Sn.Asikral
Çok teşekkür ederim.
küçük bir işlem daha var.
Örnek, 1000 tl ödenecek tutara karşılık 500 tl ödeniyor ya.o satırdaki ödenecek olan 1000 tl.nin ödenen tutara eşit olması gerekiyor.
Bold olan tutarın 500 tl olması gerekiyor.
ödenecek ödenen
1000 500
500
Genişletmek için tıkla ...

merhaba,
Tam istediğim gibi olmuş ellerinize sağlık.
Fakat alıntı olarak istediğim ve sizinde yaptığınız özellik kaybolmuş.
Bunuda bir düzeltirseniz bu sefer tamam herhalde:)
Hakkınızı helal ediniz.
Selametle kalınız.
 
kemal turan' Alıntı:
merhaba,
Tam istediğim gibi olmuş ellerinize sağlık.
Fakat alıntı olarak istediğim ve sizinde yaptığınız özellik kaybolmuş.
Bunuda bir düzeltirseniz bu sefer tamam herhalde:)
Hakkınızı helal ediniz.
Selametle kalınız.
Genişletmek için tıkla ...

Kod güncellemesi
 
Merhaba,
Allah razı olsun.
İşiniz rast gitsin.
Selametle kalın.
 
Merhaba,
Yukarıdaki kodunuzu kullandığım sayfada arama Textbox işlemi var.Bu çalışmıyor.Bunun çalışması için nasıl revize etmemiz gerekiyor.
Teşekkür ederim.

Option Explicit
Private Sub TextBox1_Change()

On Error Resume Next
METİN1 = TextBox1.Value
Set FC2 = Range("B2:b65000").Find(What:=METİN1)
Application.GoTo Reference:=Range(FC2.Address), _
Scroll:=False
Selection.AutoFilter Field:=2, Criteria1:="*" & TextBox1.Value & "*"
If METİN1 = "" Then
Selection.AutoFilter Field:=2
Range("A65536").End(xlUp).Offset(1, 0).Select
End If

End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Sheets("CARİ").[J1] = 1 Then Exit Sub
On Error GoTo Son
If Intersect(Target, [A2]) Is Nothing Then
On Error Resume Next
Sheets(CStr(Target.Value)).Select
End If
If Not Intersect(Target, [G:G]) Is Nothing Then
If Target.Value = "" Then
Target.Offset(0, 1) = ""
Target.Offset(0, 3) = ""
Target.Offset(0, 4) = ""
Else
If Target.Offset(0, 1) = "" Then Target.Offset(0, 1) = Date
If Target.Offset(0, 3) = "" Then Target.Offset(0, 3) = "TAHSİLAT"
If Target.Offset(0, 4) = "" Then Target.Offset(0, 4) = "SATIŞ-TAKSİT"
End If
End If
Son:

Application.EnableEvents = False
If Target.Count = 1 Then
If Intersect(Target, Range("G2:G" & Rows.Count)) Is Nothing Then _
Application.EnableEvents = True: Exit Sub
If Target = Empty Then Application.EnableEvents = True: Exit Sub
If Cells(Target.Row, "F") > Target Then
Rows(Target.Row + 1).Insert shift:=xlDown
Cells(Target.Row + 1, "A") = Cells(Target.Row, "A")
Cells(Target.Row + 1, "B") = Cells(Target.Row, "B")
Cells(Target.Row + 1, "C") = Cells(Target.Row, "C")
Cells(Target.Row + 1, "D") = Cells(Target.Row, "D")
Cells(Target.Row + 1, "E") = Cells(Target.Row, "E")
Cells(Target.Row + 1, "F") = Cells(Target.Row, "F") - Target
Cells(Target.Row, "F") = Target
End If: End If
Application.EnableEvents = True



End Sub
 
Merhaba,
Yukarıdaki mesajımın içerisinde bulunan aşağıdaki filtre kodu çalışmıyor.
Çalışması için yukarıdaki kodun revize edilmesine ihtiyacım var.
Yardımlarınızı bekliyorum.
Teşekkürler

Option Explicit
Private Sub TextBox1_Change()

On Error Resume Next
METİN1 = TextBox1.Value
Set FC2 = Range("B2:b65000").Find(What:=METİN1)
Application.GoTo Reference:=Range(FC2.Address), _
Scroll:=False
Selection.AutoFilter Field:=2, Criteria1:="*" & TextBox1.Value & "*"
If METİN1 = "" Then
Selection.AutoFilter Field:=2
Range("A65536").End(xlUp).Offset(1, 0).Select
End If
 
Ben dosyada böyle bir özellik görmedim.
Dosyanızı buna göre güncelleyin.
 
merhaba,
Orjinal dosya boyutu 15 mb olması ve siteye yük olmaması açısından dosya eklemeden çözüm olabilir diye düşünmüştüm.
Orjinal dosyamdaki diğer sayfaları sadeleştirerek ekledim.
Sron Cari sayfasındaki filtre kodu çalışmıyor.
Teşekkür ederim.
 

Ekli dosyalar

Son düzenleme:
Dosyanızı açamıyorum soru soruyor ne evet de ne hayır de hayır dosya açılıyor direk kapanış yapıyor.
 
Merhaba,
Kusura bakmayın.
Orjinal dosyamız özel bilgileri içerdiğinden başka bilgisayarda çalışmasını engelleyici kod vardı.
Kaldırdım.
Sabrınız içinde ayrıca teşekkür ederim.
 
Kod çalışıyor sadece problem şu siz kodun sonuna filtre sonlandırması yapmışsınız ondan size çalışmıyor gibi geliyor
 
Sn.asikral,
Verdiğiniz kod çalışıyor onda sorun yok , filtre kodununda çalışması için nasıl bir düzenleme yapılması gerekiyor?
Teşekkür ederim.
 
kemal turan' Alıntı:
Sn.asikral,
Verdiğiniz kod çalışıyor onda sorun yok , filtre kodununda çalışması için nasıl bir düzenleme yapılması gerekiyor?
Teşekkür ederim.
Genişletmek için tıkla ...

Merhaba
Dosyayı dener misiniz_?
Not : Sadece Textbox'un çalışmasını sağladım.
Filtrenin kaldırılması için boş bir hücrede F2+Enter işlemi yapmanız yeterli.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst