Açık Fatura İle Çek Tutarı Kapatma İşlemi / döngüsü

W

walabi

Altın Üye
Katılım
22 Eylül 2012
Mesajlar
991
Excel Vers. ve Dili
excel 2010

excel 2013
Altın Üyelik Bitiş Tarihi
06-08-2025
Merhaba iyi akşamlar.

Ekli dosyada muhasebe mantığı ile Açık Müşteri Faturaları İle Müşterilerden alınan çek ya da benzeri tahsilatları Kapatacak / Eşleştircek bir uygulama yapmaya çalışıyorum. Dosya üzerinde açıklama yapmaya çalıştım.

Tarih bazlı olarak müşteriye düzenlenen faturaları müşterilerden gelen çek/senet gibi tahsilat tutarları ile kapatmaya / eşleştirmeye çalışıyorum. Düz bir cümle " aldığım çek tutarı kestiğim faturalardan hangisini kapatıyor " şeklinde düşünülebilir. Örnek dosyada bunun için Fatura ile ilgili bir tutar sütunu Çek ile de iki sütun yer alıyor. Toplam çek tutarını girdiğim zaman hemen yandaki sütuna fatura tutarı kadar çek tutarlarını dağıtmasını ve işlem sonunda kalan dağıtım farkının ise yeni açılacak bir alt satırda gösterilmesini istiyorum. Kapanan faturalar karşısında Durum sütununda Kapalı yazsın.

Anlatmaya çalıştıklarımın excel yönünden vba ile çözümü olabilir mi?
 

Ekli dosyalar

halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,853
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
kod
CSS: 
Sub fatura()

Syf1 = ActiveSheet.Name

Worksheets(Syf1).Columns("J:J").ClearContents
Sheets(Syf1).Cells(1, 10).Value = "Dağıtım Tutarı"
Worksheets(Syf1).Columns("f:f").ClearContents
Sheets(Syf1).Cells(1, 6).Value = "Durum"

topla1 = 0
deg = 0
son = Worksheets(Syf1).Cells(Rows.Count, 1).End(3).Row
topla1 = WorksheetFunction.Sum(Worksheets(Syf1).Range("I2:I" & son))
Sheets(Syf1).Range(Sheets(Syf1).Cells(2, 6), Sheets(Syf1).Cells(son, 6)).Value = "Açık"

For m = Worksheets(Syf1).Cells(Rows.Count, 5).End(3).Row To 2 Step -1
'Sheets(Syf1).Cells(m, 6).Value = "Açık"
If Sheets(Syf1).Cells(m, 3).Value = "" Then
Sheets(Syf1).Rows(m).Delete Shift:=xlUp
End If
Next m


For i = 2 To Worksheets(Syf1).Cells(Rows.Count, 4).End(3).Row
If topla1 > Sheets(Syf1).Cells(i, 4).Value Then
Sheets(Syf1).Cells(i, 10).Value = Sheets(Syf1).Cells(i, 4).Value
Sheets(Syf1).Cells(i, 6).Value = "Kapalı"
topla1 = topla1 - Sheets(Syf1).Cells(i, 4).Value
Else

If deg = 0 Then
Sheets(Syf1).Cells(i, 10).Value = topla1
Sheets(Syf1).Rows(i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets(Syf1).Cells(i + 1, 4).Value = Sheets(Syf1).Cells(i, 4).Value - topla1
Sheets(Syf1).Cells(i + 1, 11).Value = "=IF(ISTEXT(R[-1]C),RC[-7]-RC[-2],R[-1]C+RC[-7]-RC[-2])"
Sheets(Syf1).Cells(i + 1, 1).Value = Sheets(Syf1).Cells(i, 1).Value
Sheets(Syf1).Rows(i + 1).Font.Color = -16776961
Sheets(Syf1).Cells(i + 1, 6).Value = "Açık"
topla1 = 0
deg = 1
End If
End If

Next i

MsgBox "işlem tamam"
 
Son düzenleme:
W

walabi

Altın Üye
Katılım
22 Eylül 2012
Mesajlar
991
Excel Vers. ve Dili
excel 2010

excel 2013
Altın Üyelik Bitiş Tarihi
06-08-2025
halit3' Alıntı:
kod
CSS: 
Sub fatura()

Syf1 = ActiveSheet.Name

Worksheets(Syf1).Columns("J:J").ClearContents
Sheets(Syf1).Cells(1, 10).Value = "Dağıtım Tutarı"
Worksheets(Syf1).Columns("f:f").ClearContents
Sheets(Syf1).Cells(1, 6).Value = "Durum"

topla1 = 0
deg = 0
son = Worksheets(Syf1).Cells(Rows.Count, 1).End(3).Row
topla1 = WorksheetFunction.Sum(Worksheets(Syf1).Range("I2:I" & son))
Sheets(Syf1).Range(Sheets(Syf1).Cells(2, 6), Sheets(Syf1).Cells(son, 6)).Value = "Açık"

For m = Worksheets(Syf1).Cells(Rows.Count, 5).End(3).Row To 2 Step -1
'Sheets(Syf1).Cells(m, 6).Value = "Açık"
If Sheets(Syf1).Cells(m, 3).Value = "" Then
Sheets(Syf1).Rows(m).Delete Shift:=xlUp
End If
Next m


For i = 2 To Worksheets(Syf1).Cells(Rows.Count, 4).End(3).Row
If topla1 > Sheets(Syf1).Cells(i, 4).Value Then
Sheets(Syf1).Cells(i, 10).Value = Sheets(Syf1).Cells(i, 4).Value
Sheets(Syf1).Cells(i, 6).Value = "Kapalı"
topla1 = topla1 - Sheets(Syf1).Cells(i, 4).Value
Else

If deg = 0 Then
Sheets(Syf1).Cells(i, 10).Value = topla1
Sheets(Syf1).Rows(i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets(Syf1).Cells(i + 1, 4).Value = Sheets(Syf1).Cells(i, 4).Value - topla1
Sheets(Syf1).Cells(i + 1, 11).Value = "=IF(ISTEXT(R[-1]C),RC[-7]-RC[-2],R[-1]C+RC[-7]-RC[-2])"
Sheets(Syf1).Cells(i + 1, 1).Value = Sheets(Syf1).Cells(i, 1).Value
Sheets(Syf1).Rows(i + 1).Font.Color = -16776961
Sheets(Syf1).Cells(i + 1, 6).Value = "Açık"
topla1 = 0
deg = 1
End If
End If

Next i

MsgBox "işlem tamam"
Genişletmek için tıkla ...

Halit bey merhaba. Destek için teşekkürler öncelikle. Kodu çalıştırdığımda Dağıtım Tutarı toplamı Çek Tutarı olarak girilen tutarın 2 katını veriyor her seferinde. Dağıtım tutarları toplamları Çek Tutarı toplamı kadar olmalı.
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,853
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
örnek dosyanızda kodu çalıştırdınızmı kod örnek dosyanızda çalışıyor.
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,853
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
En altdaki toplamlarıda dahil ediyor kod ondan olmuyor.
CSS: 
Sub fatura()

With Application
.Calculation = xlManual '-4135
.ScreenUpdating = False
.EnableEvents = False
End With


Syf1 = ActiveSheet.Name

Worksheets(Syf1).Range("J:J,F:F").ClearContents
Sheets(Syf1).Cells(1, 10).Value = "Dağıtım Tutarı"
Sheets(Syf1).Cells(1, 6).Value = "Durum"

topla1 = 0
deg = 0
son = Worksheets(Syf1).Cells(Rows.Count, 5).End(3).Row
topla1 = WorksheetFunction.Sum(Worksheets(Syf1).Range("I2:I" & son))
Sheets(Syf1).Range(Sheets(Syf1).Cells(2, 6), Sheets(Syf1).Cells(son, 6)).Value = "Açık"

For m = Worksheets(Syf1).Cells(Rows.Count, 5).End(3).Row To 2 Step -1
If Sheets(Syf1).Cells(m, 3).Value = "" Then
Sheets(Syf1).Rows(m).Delete Shift:=xlUp
End If
Next m

For i = 2 To Worksheets(Syf1).Cells(Rows.Count, 5).End(3).Row
If topla1 > Sheets(Syf1).Cells(i, 4).Value Then
Sheets(Syf1).Cells(i, 10).Value = Sheets(Syf1).Cells(i, 4).Value
Sheets(Syf1).Cells(i, 6).Value = "Kapalı"
topla1 = topla1 - Sheets(Syf1).Cells(i, 4).Value
Else

If deg = 0 Then
Sheets(Syf1).Cells(i, 10).Value = topla1
Sheets(Syf1).Rows(i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets(Syf1).Cells(i + 1, 4).Value = Sheets(Syf1).Cells(i, 4).Value - topla1
Sheets(Syf1).Cells(i + 1, 11).Value = "=IF(ISTEXT(R[-1]C),RC[-7]-RC[-2],R[-1]C+RC[-7]-RC[-2])"
Sheets(Syf1).Cells(i + 1, 1).Value = Sheets(Syf1).Cells(i, 1).Value
Sheets(Syf1).Rows(i + 1).Font.Color = 255 '-16776961
Sheets(Syf1).Cells(i + 1, 6).Value = "Açık"
topla1 = 0
deg = 1
End If
End If
Sheets(Syf1).Cells(i, 11).Value = "=IF(ISTEXT(R[-1]C),RC[-7]-RC[-2],R[-1]C+RC[-7]-RC[-2])"
Next i

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With

MsgBox "işlem tamam"

End Sub
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,853
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Birde bu kodu dene
Kod: 
Sub fatura()

With Application
.Calculation = xlManual '-4135
.ScreenUpdating = False
.EnableEvents = False
End With


Syf1 = ActiveSheet.Name

Worksheets(Syf1).Range("J:J,F:F").ClearContents
Sheets(Syf1).Cells(1, 10).Value = "Dağıtım Tutarı"
Sheets(Syf1).Cells(1, 6).Value = "Durum"

topla1 = 0
deg = 0
son = Worksheets(Syf1).Cells(Rows.Count, 5).End(3).Row
topla1 = WorksheetFunction.Sum(Worksheets(Syf1).Range("I2:I" & son))
Sheets(Syf1).Range(Sheets(Syf1).Cells(2, 6), Sheets(Syf1).Cells(son, 6)).Value = "Açık"

For m = Worksheets(Syf1).Cells(Rows.Count, 5).End(3).Row To 2 Step -1
If Sheets(Syf1).Cells(m, 3).Value = "" Then
Sheets(Syf1).Rows(m).Delete Shift:=xlUp
End If
Next m

For i = 2 To Worksheets(Syf1).Cells(Rows.Count, 5).End(3).Row
If topla1 > Sheets(Syf1).Cells(i, 4).Value Then
Sheets(Syf1).Cells(i, 10).Value = Sheets(Syf1).Cells(i, 4).Value
Sheets(Syf1).Cells(i, 6).Value = "Kapalı"
topla1 = topla1 - Sheets(Syf1).Cells(i, 4).Value
Else

If deg = 0 Then
Sheets(Syf1).Cells(i, 10).Value = topla1
Sheets(Syf1).Rows(i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets(Syf1).Cells(i + 1, 4).Value = Sheets(Syf1).Cells(i, 4).Value - topla1
Sheets(Syf1).Cells(i + 1, 11).Value = "=IF(ISTEXT(R[-1]C),RC[-7]-RC[-2],R[-1]C+RC[-7]-RC[-2])"
Sheets(Syf1).Cells(i + 1, 1).Value = Sheets(Syf1).Cells(i, 1).Value
Sheets(Syf1).Rows(i + 1).Font.Color = 255 '-16776961
Sheets(Syf1).Cells(i + 1, 6).Value = "Açık"
topla1 = 0
deg = 1
End If
End If
Sheets(Syf1).Cells(i, 11).Value = "=IF(ISTEXT(R[-1]C),RC[-7]-RC[-2],R[-1]C+RC[-7]-RC[-2])"
Next i

son2 = Worksheets(Syf1).Cells(Rows.Count, 1).End(3).Row - 1

Sheets(Syf1).Cells(son2 + 1, 9).Value = WorksheetFunction.Sum(Worksheets(Syf1).Range("j2:j" & son2))

Sheets(Syf1).Range("d" & son2 + 1).Value = "=SUM(R[-" & son2 - 1 & "]C:R[-1]C)"
Sheets(Syf1).Range("I" & son2 + 1).Value = "=SUM(R[-" & son2 - 1 & "]C:R[-1]C)"
Sheets(Syf1).Range("j" & son2 + 1).Value = "=SUM(R[-" & son2 - 1 & "]C:R[-1]C)"


With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With

MsgBox "işlem tamam"

End Sub
 
W

walabi

Altın Üye
Katılım
22 Eylül 2012
Mesajlar
991
Excel Vers. ve Dili
excel 2010

excel 2013
Altın Üyelik Bitiş Tarihi
06-08-2025
halit3' Alıntı:
Birde bu kodu dene
Kod: 
Sub fatura()

With Application
.Calculation = xlManual '-4135
.ScreenUpdating = False
.EnableEvents = False
End With


Syf1 = ActiveSheet.Name

Worksheets(Syf1).Range("J:J,F:F").ClearContents
Sheets(Syf1).Cells(1, 10).Value = "Dağıtım Tutarı"
Sheets(Syf1).Cells(1, 6).Value = "Durum"

topla1 = 0
deg = 0
son = Worksheets(Syf1).Cells(Rows.Count, 5).End(3).Row
topla1 = WorksheetFunction.Sum(Worksheets(Syf1).Range("I2:I" & son))
Sheets(Syf1).Range(Sheets(Syf1).Cells(2, 6), Sheets(Syf1).Cells(son, 6)).Value = "Açık"

For m = Worksheets(Syf1).Cells(Rows.Count, 5).End(3).Row To 2 Step -1
If Sheets(Syf1).Cells(m, 3).Value = "" Then
Sheets(Syf1).Rows(m).Delete Shift:=xlUp
End If
Next m

For i = 2 To Worksheets(Syf1).Cells(Rows.Count, 5).End(3).Row
If topla1 > Sheets(Syf1).Cells(i, 4).Value Then
Sheets(Syf1).Cells(i, 10).Value = Sheets(Syf1).Cells(i, 4).Value
Sheets(Syf1).Cells(i, 6).Value = "Kapalı"
topla1 = topla1 - Sheets(Syf1).Cells(i, 4).Value
Else

If deg = 0 Then
Sheets(Syf1).Cells(i, 10).Value = topla1
Sheets(Syf1).Rows(i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets(Syf1).Cells(i + 1, 4).Value = Sheets(Syf1).Cells(i, 4).Value - topla1
Sheets(Syf1).Cells(i + 1, 11).Value = "=IF(ISTEXT(R[-1]C),RC[-7]-RC[-2],R[-1]C+RC[-7]-RC[-2])"
Sheets(Syf1).Cells(i + 1, 1).Value = Sheets(Syf1).Cells(i, 1).Value
Sheets(Syf1).Rows(i + 1).Font.Color = 255 '-16776961
Sheets(Syf1).Cells(i + 1, 6).Value = "Açık"
topla1 = 0
deg = 1
End If
End If
Sheets(Syf1).Cells(i, 11).Value = "=IF(ISTEXT(R[-1]C),RC[-7]-RC[-2],R[-1]C+RC[-7]-RC[-2])"
Next i

son2 = Worksheets(Syf1).Cells(Rows.Count, 1).End(3).Row - 1

Sheets(Syf1).Cells(son2 + 1, 9).Value = WorksheetFunction.Sum(Worksheets(Syf1).Range("j2:j" & son2))

Sheets(Syf1).Range("d" & son2 + 1).Value = "=SUM(R[-" & son2 - 1 & "]C:R[-1]C)"
Sheets(Syf1).Range("I" & son2 + 1).Value = "=SUM(R[-" & son2 - 1 & "]C:R[-1]C)"
Sheets(Syf1).Range("j" & son2 + 1).Value = "=SUM(R[-" & son2 - 1 & "]C:R[-1]C)"


With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With

MsgBox "işlem tamam"

End Sub
Genişletmek için tıkla ...

Özür dilerim. Satır eklemekle ilgili kısımda bir detayı eksik anlatmışım. Satır eklendikten sonra eklenen satıra kalan tutar ekleniyor. Bir de şunu istemem gerekiyordu. Eklenen satırdan hemen önceki fatura tutarı da eşleşen çek tutarı kadar yeniden oluşmalı . Örneğin Fatura tutarı 55 TL . Çek tutarı bunun 45 TL sini kapatmış olsun. Eklenen satırda Faturanın kalan tutarı 10 TL olarak gözükecek. Fatura nın asıl tutarı ise 55 iken bunun çekin kapattığı tutar olan 45 TL olarak yeniden değer almasını istiyordum.
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,853
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu söylediğinizi kod yapmıyormu
eğer yapmıyorsa yukarıdaki mesajınızdaki duruma göre örnek dosya ekleyiniz.
 
W

walabi

Altın Üye
Katılım
22 Eylül 2012
Mesajlar
991
Excel Vers. ve Dili
excel 2010

excel 2013
Altın Üyelik Bitiş Tarihi
06-08-2025
halit3' Alıntı:
Bu söylediğinizi kod yapmıyormu
eğer yapmıyorsa yukarıdaki mesajınızdaki duruma göre örnek dosya ekleyiniz.
Genişletmek için tıkla ...
3 ayrı çek gelme durumuna göre tablonun oluşmasını istediğim halini 3 ayrı excel sayfasında birbirinin devamı şeklinde göstermeye çalıştım. Kodlarınız modülde
 

Ekli dosyalar

W

walabi

Altın Üye
Katılım
22 Eylül 2012
Mesajlar
991
Excel Vers. ve Dili
excel 2010

excel 2013
Altın Üyelik Bitiş Tarihi
06-08-2025
halit3' Alıntı:
Bu söylediğinizi kod yapmıyormu
eğer yapmıyorsa yukarıdaki mesajınızdaki duruma göre örnek dosya ekleyiniz.
Genişletmek için tıkla ...

Halit bey I sütunu yani manuel olarak veri girmeyi planladığım Çek Tutarı sütununda temizleme işlemi olmasına gerek. I sütununa manuel veri gireceğim. Bu sebeple oraya manuel girilen veri yani çek tutarı olduğu gibi kalmalı. Kodlarda I sütununda temizleme işlemi yapıyor sanırım. Hatta dip toplamlara da gerek yok. Ben kontrol amaçlı yapmıştım. Ancak olmasında sakınca yok tabi ki.
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,853
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu kodu bir dene
Kod: 
Sub fatura4()

With Application
.Calculation = xlManual '-4135
.ScreenUpdating = False
.EnableEvents = False
End With

Syf1 = ActiveSheet.Name
topla1 = 0

For i = 2 To Worksheets(Syf1).Cells(Rows.Count, 5).End(3).Row
topla1 = topla1 + Sheets(Syf1).Cells(i, 9).Value

If topla1 > Sheets(Syf1).Cells(i, 4).Value Then
Sheets(Syf1).Cells(i, 10).Value = Sheets(Syf1).Cells(i, 4).Value
Sheets(Syf1).Cells(i, 6).Value = "Kapalı"
Else
If topla1 > 0 Then
Sheets(Syf1).Cells(i, 10).Value = topla1
End If
End If
topla1 = topla1 - Sheets(Syf1).Cells(i, 4).Value

Next i

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With

MsgBox "işlem tamam"

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