Cari hareketleri aylara ve para birimine göre yaşlandırma

[dost]

Merhaba,

Aşağıdaki kodları dener misiniz.

Sub yillik_hrk_raporu()
  Dim s1, s2 As Worksheet
  Dim data1, data2, data3, data4, crite, crite2 As String
  Dim r, lRow1 As Long
  Dim tBorc, tAlc, tAlcKum, tBrcKum, bakiye As Double
  Dim c, lRow2 As Byte

  Application.ScreenUpdating = False

  Set s1 = ThisWorkbook.Sheets("kayıt")
  Set s2 = ThisWorkbook.Sheets("Rapor")
  lRow1 = s1.Cells(Rows.Count, 2).End(xlUp).Row
  lRow2 = s2.Cells(Rows.Count, 2).End(xlUp).Row
   
  data1 = s1.Name & "!" & s1.Range("B5:B" & lRow1).Address
  data2 = s1.Name & "!" & s1.Range("E5:E" & lRow1).Address
  data3 = s1.Name & "!" & s1.Range("F5:F" & lRow1).Address
  data4 = s1.Name & "!" & s1.Range("G5:G" & lRow1).Address
  crite2 = s2.Range("B3").Address

  s2.Range(s2.Range("C4"), s2.Range("P" & lRow2)).ClearContents

  For r = 4 To lRow2 'Para birimine göre satırlarda döner
    crite = s2.Cells(r, "B").Address
    tBrcKum = Evaluate("=SUMPRODUCT(--(" & data2 & " = " & crite & "), --(YEAR(" & data1 & ") = " & crite2 & "), --(" & data3 & "))")
    tAlcKum = Evaluate("=SUMPRODUCT(--(" & data2 & " = " & crite & "), --(YEAR(" & data1 & ") = " & crite2 & "), --(" & data4 & "))")
    toplam = 0
   
    For c = 3 To 15 'Devir ve Aylar sütununda döner
       
        If c = 3 Then 'Devir kısmına girer
            tBorc = Evaluate("=SUMPRODUCT(--(" & data2 & "=" & crite & "), --(YEAR(" & data1 & ") < " & crite2 & "), --(" & data3 & "))")
            tAlc = Evaluate("=SUMPRODUCT(--(" & data2 & "=" & crite & "), --(YEAR(" & data1 & ") < " & crite2 & "), --(" & data4 & "))")
            tBrcKum = tBrcKum + tBorc
            tAlcKum = tAlcKum + tAlc
            bakiye = WorksheetFunction.Min(tAlcKum, tBrcKum)
        Else  'Aylar kısmına girer
            tBorc = Evaluate("=SUMPRODUCT(--(" & data2 & "=" & crite & "),--(Month(" & data1 & ")=" & CByte((c - 3)) & "), --(YEAR(" & data1 & ")=" & crite2 & "), --(" & data3 & "))")
            tAlc = Evaluate("=SUMPRODUCT(--(" & data2 & "=" & crite & "),--(Month(" & data1 & ")=" & CByte((c - 3)) & "), --(YEAR(" & data1 & ")=" & crite2 & "), --(" & data4 & "))")
        End If
       
        If s2.Cells(1, "A") = "Borç" Then
            s2.Cells(r, c) = tBorc
        ElseIf s2.Cells(1, "A") = "Alacak" Then
            s2.Cells(r, c) = tAlc
        ElseIf s2.Cells(1, "A") = "Bakiye" Then
            s2.Cells(r, c) = tBorc - tAlc
        ElseIf s2.Cells(1, "A") = "Mahsup" Then
            If (tAlcKum - tBrcKum) > 0 Then
                If tAlc > 0 Then
                    If tAlc <= bakiye Then
                        bakiye = bakiye - tAlc
                   Else
                        s2.Cells(r, c) = -(tAlc - bakiye)
                        bakiye = 0
                   End If
                End If
            Else
                If tBorc > 0 Then
                   If tBorc <= bakiye Then
                        bakiye = bakiye - tBorc
                   Else
                        s2.Cells(r, c) = tBorc - bakiye
                        bakiye = 0
                   End If
                End If
            End If
        End If
        toplam = toplam + s2.Cells(r, c)
    Next c
   
    s2.Cells(r, c) = toplam
  Next r

  Application.ScreenUpdating = True

End Sub

 

[ATEMİ]

sayın dost denedim ama olmadı bende hata yapmış olabilirim gerçi

 

[dost]

Merhaba,

Dosya ektedir. Bu dosya üzerinden gidelim bence.
Nerede problem varsa onu yazarsınız.

 

[dost]

Merhaba,

Senin isteklerinde yazdıklarına göre doğru olması gerek. Algoritma şu şekilde:

Seçenek = "Borç" ise
    ilgili ay tutarı = o ayın borç toplamı
Seçenek = "Alacak" ise
    ilgili ay tutarı = o ayın alacak toplamı
Seçenek = "Bakiye" ise
    ilgili ay tutarı = o ayın borç toplamı - o ayın alacak toplamı
Seçenek = "Mahsup" ise
     bütün borçları topla
     bütün alacakları topla
     hangi değer küçük ise (örneğin alacak toplamı) bu tutarı değişkene ata
     her ayki borç toplamından bu tutarı düş (mahsuplaş)
     Eğer değişken => o ayın borç toplamından        
          ilgili ay tutarı = 0
         değişken = değişken - o ayın borç toplamı  (değişkenden o ayın borcu kadar mahsuplaş)
     Eğer o ayın borç toplamı> değişkenden
         ilgili ay tutarı = o ayın borç toplamı - değişken
         değişken = 0
         ilgili ay tutarı = o ayın borç toplamı (sonraki borç veren aylar)
         borç toplamı daha küçük ise yukarıda işlemlerin tam tersini yap

 

[ATEMİ]

Üstadım ben buna yarın baksam sakıncası olur mu çok özür dilerim

 

[ATEMİ]

Sayın dost sonuçlar doğru. yalnız hesapla butonu olmadan sadece A1 tercihlerini seçerek bu sonucu alamaz mıyız?

 

[dost]

Merhaba,

Sheet2 (Rapor) Code bölümüne aşğıdaki kodları kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) = "A1" Then Call yillik_hrk_raporu
End Sub

 

[ATEMİ]

üstadım her şey için yürekten teşekkür ederim çok yardımcı oldunuz ben fonksiyon ile yapmak istedim bir türlü olmadı bu da işimi görüyor sağolun

 

[ATEMİ]

bir de bunu örnek sayfa üzerinde yaptık asıl sayfaya uyarlamada sıkıntı yaşamamak adına öneriniz var mı

 

[dost]

Merhaba,

Module1
Sub yillik_hrk_raporu()

Set s1 = ThisWorkbook.Sheets("kayıt")     'Asıl dosyandaki sayfa isimini kullanırsın
Set s2 = ThisWorkbook.Sheets("Rapor")    'Asıl dosyandaki sayfa isimini kullanırsın

Kayıt sayfası verisindeki tablo sütunlarında değişiklik olursa kodda değişiklik yapılması gerekir.

'Aşağıdaki kodu Rapor almak istediğin sayfanın Code bölümüne kopyalarsın.
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) = "A1" Then Call yillik_hrk_raporu  'Seçenekler A1 hücresi yerine başka hücre kullanırsan Bu koddaki "A1" i değiştirirsin.
End Sub