Enflasyon Muhasebesi Çalışması

[cavanoos]

Merhaba arkadaşlar;

Muhasebecilerin başı enflasyon muhasebesi ile dertte, bu soruna çözüm arıyorum.
Ekteki örnek dosyada yapılmak istenilen şey şudur ?
Öncelikle iki adet hesap kodumuz var. 153.01.001 ve 153.01.002
Sene sonunda 153.01.001 hesap da 61.000 TL ve 153.01.002 hesap da ise 33.000 TL bakiye kalmış.

Bizden istenilen ise şudur:

153.01.001 hesabın sene sonu bakiyesi olan 61.000 TL en son stok girişinden geriye doğru giderek,
61.000 TL nin hangi tarihlerden geldiğini bulmak.
Sonuç aşağıdaki gibi olacak

10.11.2023 1.000 TL
10.10.2023 7.000 TL
10.09.2023 24.000 TL
10.08.2023 28.000 TL
10.07.2023 1.000 TL

Tabi ki diğer hesap içinde aynı işlemler olacak. Bu tutarlar G sütununda olmalı


Ekteki örnek dosya üzerinde çalıştım ama beceremedim.
Kolaylık olması açısından E sütununu silerek, D sütununda boş hücreleri silerek ve bakiye sütununu da silebiliriz
Fakat bakiye tutarını başka bir hücreye yazmalıyız ki o hücreyi referans alabilsin.

Yardımcı olabilir misiniz ?

 

[cavanoos]

Amacımız dosyanın yalın hali üzerinden hesaplama yapmaktı ama belki uzun anlattım, kafa karışıklığı oldu.
Dosyayı sadeleştirdim ve yapılması gerekenleri azalttım.
Bir de bu şekilde yardımcı olabilecek, fikir sunabilecek arkadaşlar arıyorum.

Ekli dosyamda;
Mizan sayfasında hesap kodu ve tutarı var.
İkinci çalışma sayfasında ise verilerimiz var.

İşlem koşulu ise : Toplam sayıya ulaştıran satırları belirlemek istiyoruz.
Örnek verirsek Mizan sayfasında 153.01.001 hesabın tutarı 61.000 TL
Bu tutara ikinci çalışma sayfasında ilk satırdan başlayarak ulaşmayı hedefliyoruz. Manuel olarak D sütununda rakamları yazdım.
İlgili örneğimizi ise sarıya boyadım. İşte bu işlemi manuel değil de fonksiyon yada makro ile yapabilir miyiz ?

 

[besen]

Çok fazla farklı ve daha esnek çözümler paylaşılacaktır. Ben benzer konu için kendi çözümümü paylaşıyorum.
Ancak kodların böyle karışık sırayla değil, koda göre ve yeni tarihten, eski tarihe göre sıralanmalıdır.
Başka bir cevap gelene kadar işinizi görür.

 

[cavanoos]

Emeğinize sağlık, evet tam olarak aradığımız bu değil ama hiç yoktan iyidir.
Eğer formülü ile nasıl yapılır diye kafa yoruyordum, siz yapmışsınız, saolun.

Fakat her hesap için ayrı bir düzenleme yapmak, ona göre formül ayarlamak zaman alır.
200 adet hesap kodu için böyle bir çalışma yapacağım.

Besen'in formülünü daha da geliştirebilecek olan var mıdır ?

 

[veyselemre]

Sub test()
    Dim dic As Object, i&, ky$, kalan, borc
    Set dic = CreateObject("Scripting.Dictionary")
    With Sheets("Mizan")
        For i = 2 To .Cells(Rows.Count, 1).End(3).Row
            dic.Item(.Cells(i, 1).Value) = .Cells(i, 2).Value
        Next i
    End With
    With Sheets("İkinci Çalışma")
        .Cells.Clear
        Sheets("Ekstre").Range("A1").CurrentRegion.Resize(, 4).Copy .Range("A1")
        .Columns.AutoFit
        .Range("A1").CurrentRegion.Sort .Range("D1"), , , , , , , xlYes
        .Rows(.Cells(Rows.Count, "D").End(3).Row + 1 & ":" & Rows.Count).ClearContents
        .Range("A1").CurrentRegion.Sort .Range("C1"), , .Range("B1"), , xlDescending, , , xlYes
        .Range("E1").Value = "Tutar"
        For i = 2 To .Cells(Rows.Count, 1).End(3).Row
            ky = .Cells(i, 3).Value
            borc = .Cells(i, 4).Value
            kalan = dic(ky)
            If kalan > 0 Then
                If kalan >= borc Then
                    .Cells(i, 5).Value = .Cells(i, 4).Value
                    dic(ky) = kalan - borc
                Else
                    .Cells(i, 5).Value = kalan
                    dic(ky) = 0
                End If
            End If
        Next i
    End With
End Sub

 

[cavanoos]

Üstadım teşekkür ederim, tam olarak istediğimiz buydu.

 

[besen]

Sub test()
    Dim dic As Object, i&, ky$, kalan, borc
    Set dic = CreateObject("Scripting.Dictionary")
    With Sheets("Mizan")
        For i = 2 To .Cells(Rows.Count, 1).End(3).Row
            dic.Item(.Cells(i, 1).Value) = .Cells(i, 2).Value
        Next i
    End With
    With Sheets("İkinci Çalışma")
        .Cells.Clear
        Sheets("Ekstre").Range("A1").CurrentRegion.Resize(, 4).Copy .Range("A1")
        .Columns.AutoFit
        .Range("A1").CurrentRegion.Sort .Range("D1"), , , , , , , xlYes
        .Rows(.Cells(Rows.Count, "D").End(3).Row + 1 & ":" & Rows.Count).ClearContents
        .Range("A1").CurrentRegion.Sort .Range("C1"), , .Range("B1"), , xlDescending, , , xlYes
        .Range("E1").Value = "Tutar"
        For i = 2 To .Cells(Rows.Count, 1).End(3).Row
            ky = .Cells(i, 3).Value
            borc = .Cells(i, 4).Value
            kalan = dic(ky)
            If kalan > 0 Then
                If kalan >= borc Then
                    .Cells(i, 5).Value = .Cells(i, 4).Value
                    dic(ky) = kalan - borc
                Else
                    .Cells(i, 5).Value = kalan
                    dic(ky) = 0
                End If
            End If
        Next i
    End With
End Sub

Veysel Bey çözümü benim dosyama da uyarlayabilir misiniz. Teşekkür ederim.
Açıklama dosyanın içinde.

 

[maliex]

Sub test()
    Dim dic As Object, i&, ky$, kalan, borc
    Set dic = CreateObject("Scripting.Dictionary")
    With Sheets("Stok")
        For i = 2 To .Cells(Rows.Count, "U").End(3).Row
            dic.Item(.Cells(i, "U").Value) = .Cells(i, "V").Value
        Next i
    End With
    With Sheets("Stok")

        For i = 2 To .Cells(Rows.Count, "J").End(3).Row
            ky = .Cells(i, "D").Value
            borc = .Cells(i, "J").Value
            kalan = dic(ky)
            If kalan > 0 Then
                If kalan >= borc Then
                    .Cells(i, "S").Value = .Cells(i, "J").Value
                    dic(ky) = kalan - borc
                Else
                    .Cells(i, "S").Value = kalan
                    dic(ky) = 0
                End If
            End If
        Next i
    End With
End Sub

 

[besen]

Sub test()
    Dim dic As Object, i&, ky$, kalan, borc
    Set dic = CreateObject("Scripting.Dictionary")
    With Sheets("Stok")
        For i = 2 To .Cells(Rows.Count, "U").End(3).Row
            dic.Item(.Cells(i, "U").Value) = .Cells(i, "V").Value
        Next i
    End With
    With Sheets("Stok")

        For i = 2 To .Cells(Rows.Count, "J").End(3).Row
            ky = .Cells(i, "D").Value
            borc = .Cells(i, "J").Value
            kalan = dic(ky)
            If kalan > 0 Then
                If kalan >= borc Then
                    .Cells(i, "S").Value = .Cells(i, "J").Value
                    dic(ky) = kalan - borc
                Else
                    .Cells(i, "S").Value = kalan
                    dic(ky) = 0
                End If
            End If
        Next i
    End With
End Sub

Teşekkür ederim. Doğru çalışanlar var ancak mesela bu kodunkiler yanlış gelmiş, bir bakar mısınız.

 

[maliex]

belirttiğiniz stok yetersiz giriş var

	kalan	giriş	fark
C241106774 045	1895​	1649​	246​

aşağıdakilerinde girişi yok

Stok Kodu	Stok Adet
C222111608 005	8,00​
C222111609 017	390,00​
C222111609 021	10,00​
C222111610 008	1,00​
C222888621 001	1,00​
C222888621 002	5,00​
C241111775 004	248,00​
C241111775 044	247,00​
C241111792 001	251,00​
A2411011072 013	2,00​

 

[besen]

belirttiğiniz stok yetersiz giriş var

	kalan	giriş	fark
C241106774 045	1895​	1649​	246​

aşağıdakilerinde girişi yok

Stok Kodu	Stok Adet
C222111608 005	8,00​
C222111609 017	390,00​
C222111609 021	10,00​
C222111610 008	1,00​
C222888621 001	1,00​
C222888621 002	5,00​
C241111775 004	248,00​
C241111775 044	247,00​
C241111792 001	251,00​
A2411011072 013	2,00​

Haklısınız, tekrar çok teşekkür ederim.
Emeğinize yüreğinize sağlık.