Soru Mizandan Veri Alınarak Otomatik Bilanço ve Gelir Tablosu Yapmak,

[Mehmetakkoyunlu]

Merhabalar,

Ekteki dosyada mizan ve mizanadan oluşturmak istediğim gelir tablosu ile bilanço var. Bu düşeyara vb. formüller ile de yapabilir ama ben makro-vba ile yapmak istiyorum. Bu konuda izlediğim videolar ile bir şeyler yapmaya çalıştım fakat yapamadım.

Yapmak istediklerim;

Gelir tablosu sayfası D sütununda C4 den başlayarak ilgili kodu ilgili sayfalarda arayarak, eğer mizanda G sütunu doluysa veriyi oradan almak, G sütunu boş ise E ve f sütunlarından dolu olanı almak, İlgili kod mizanlarda yok ise 0 yazmak,
Örneğin 600 kodun karşılığı olarak D4 e 15.000 yazılması , E4'e ise 6.805,66 yazılması

Bilanço sayfasında da yine aynı şekilde sadece dolgu olmayan hücrelerdeki kodların karşılığında ilgili yerlere verilerin gelmesi gerekiyor.

İlgilenen yardımcı olan herkese şimdiden çok teşekkür ederim.

 

[dost]

Merhaba,

Gelir Hesaplarındaki tutarların borç ve alacak yerlerinin doğru olmadığını görüyorum. Ancak bu konuya hiç girmeyeceğim.

Gelir tablosunda 61, 62, 63, 65, 66, 68'li grup ile yansıtma yapmadığın için 7'li grup (-) olarak gözükecek şekilde olan aşağıdaki kodları denersiniz.

Sub Gelir_Tablosu_Oluştur()

Dim sName As Variant
Dim i, y, sonsat3 As Integer
Dim bToplam, aToplam As Double
Dim s3, rangeA, rangeE, rangeF, rangeG


On Error GoTo ErrHandler:

Application.ScreenUpdating = False

sName = Array("Mizan_Önceki_Dönem", "Mizan_Cari")

Set s3 = Sheets("Gelir_Tablosu")
sonsat3 = s3.Cells(Rows.Count, "C").End(xlUp).Row

For i = 4 To sonsat3
    If s3.Range("C" & i) <> "" Then
        For y = 0 To UBound(sName)
            bToplam = 0:   aToplam = 0
            sonsat = Sheets(sName(y)).Cells(Rows.Count, "A").End(xlUp).Row
            rangeA = Range("A2:A" & sonsat).Address
            rangeE = Range("E2:E" & sonsat).Address
            rangeF = Range("F2:F" & sonsat).Address
            rangeG = Range("G2:G" & sonsat).Address
            bToplam = Evaluate("=SumProduct(--(" & sName(y) & "!" & rangeA & "=""" & s3.Range("C" & i) & _
                                    """)*--(" & sName(y) & "!" & rangeE & "))")
            aToplam = Evaluate("=SumProduct(--(" & sName(y) & "!" & rangeA & "=""" & s3.Range("C" & i) & _
                                    """)*--(" & sName(y) & "!" & rangeF & "))")
            s3.Cells(i, 4 + y) = (bToplam - aToplam) * -1
        Next y
    End If

Next i

Set s3 = Nothing

Application.ScreenUpdating = True

MsgBox "Gelir Tablosu oluşturulmuştur...", vbInformation

Exit Sub
 
ErrHandler:
  If Err.Number <> 0 Then MsgBox Err.Description

End Sub

 

[Mehmetakkoyunlu]

Merhaba Dost,
İlginiz için öncelikle çok teşekkür ederim.

Evet dediğiniz gibi mizan borç alacak tutarları doğru değil. Sayıları rastgele kopyalamıştım yerleri kaymıştır muhtemelen.

Gelir tablosu için verdiğiniz kodu uyguladım ve çok güzel çalıştı elinize sağlık.

Mizandaki veriler sadece metin olarak saklanan sayı olursa çalışıyor. Bunu normal sayıya çevirdiğimizde çalışmıyor. (Bazı muhasebe programlarından alınan mizan verisi sayı bazılarından alınanlar metin olarak saklanan sayı oluyor.) Buna bir çözüm var mı ?

Bir de aynı çalışmayı bilanço sayfası için nasıl uyarlayabilirim ?

 

[dost]

Merhaba,

Bilanço için deneyiniz....

Sub Bilanco_Olustur()

Dim sName As Variant
Dim i, y, k, sonsat4 As Integer
Dim bToplam, aToplam As Double
Dim s4, rangeA, rangeE, rangeF, rangeG


On Error GoTo ErrHandler:

Application.ScreenUpdating = False

sName = Array("Mizan_Önceki_Dönem", "Mizan_Cari")

Set s4 = Sheets("Bilanço")
sonsat4 = WorksheetFunction.Max(s4.Cells(Rows.Count, "A").End(xlUp).Row, s4.Cells(Rows.Count, "F").End(xlUp).Row)

For i = 7 To sonsat4
    For k = 1 To 6 Step 5
        If s4.Cells(i, k) <> "" Then
            For y = 0 To UBound(sName)
                bToplam = 0:   aToplam = 0
                sonsat = Sheets(sName(y)).Cells(Rows.Count, "A").End(xlUp).Row
                rangeA = Range("A2:A" & sonsat).Address
                rangeE = Range("E2:E" & sonsat).Address
                rangeF = Range("F2:F" & sonsat).Address
                rangeG = Range("G2:G" & sonsat).Address
                bToplam = Evaluate("=SumProduct(--(" & sName(y) & "!" & rangeA & "=""" & s4.Cells(i, k) & _
                                        """)*--(" & sName(y) & "!" & rangeE & "))")
                aToplam = Evaluate("=SumProduct(--(" & sName(y) & "!" & rangeA & "=""" & s4.Cells(i, k) & _
                                        """)*--(" & sName(y) & "!" & rangeF & "))")
                s4.Cells(i, 2 + y + k) = (bToplam - aToplam)
                Next y
        End If
    Next k

Next i

Set s4 = Nothing

Application.ScreenUpdating = True

MsgBox "Bilanço oluşturulmuştur...", vbInformation

Exit Sub

ErrHandler:
  If Err.Number <> 0 Then MsgBox Err.Description

End Sub

 

[Mehmetakkoyunlu]

Çok teşekkür ederim. Elinize sağlık.

 

[artur80]

Merhaba,

Bilanço için deneyiniz....

Sub Bilanco_Olustur()

Dim sName As Variant
Dim i, y, k, sonsat4 As Integer
Dim bToplam, aToplam As Double
Dim s4, rangeA, rangeE, rangeF, rangeG


On Error GoTo ErrHandler:

Application.ScreenUpdating = False

sName = Array("Mizan_Önceki_Dönem", "Mizan_Cari")

Set s4 = Sheets("Bilanço")
sonsat4 = WorksheetFunction.Max(s4.Cells(Rows.Count, "A").End(xlUp).Row, s4.Cells(Rows.Count, "F").End(xlUp).Row)

For i = 7 To sonsat4
    For k = 1 To 6 Step 5
        If s4.Cells(i, k) <> "" Then
            For y = 0 To UBound(sName)
                bToplam = 0:   aToplam = 0
                sonsat = Sheets(sName(y)).Cells(Rows.Count, "A").End(xlUp).Row
                rangeA = Range("A2:A" & sonsat).Address
                rangeE = Range("E2:E" & sonsat).Address
                rangeF = Range("F2:F" & sonsat).Address
                rangeG = Range("G2:G" & sonsat).Address
                bToplam = Evaluate("=SumProduct(--(" & sName(y) & "!" & rangeA & "=""" & s4.Cells(i, k) & _
                                        """)*--(" & sName(y) & "!" & rangeE & "))")
                aToplam = Evaluate("=SumProduct(--(" & sName(y) & "!" & rangeA & "=""" & s4.Cells(i, k) & _
                                        """)*--(" & sName(y) & "!" & rangeF & "))")
                s4.Cells(i, 2 + y + k) = (bToplam - aToplam)
                Next y
        End If
    Next k

Next i

Set s4 = Nothing

Application.ScreenUpdating = True

MsgBox "Bilanço oluşturulmuştur...", vbInformation

Exit Sub

ErrHandler:
  If Err.Number <> 0 Then MsgBox Err.Description

End Sub

Bilanço da Kahverengi ve yeşil alanlarıda getirdiği için toplamlar bozulmaktadır. bunun içinde nasıl bir toplamlar bozulmamsı için kod yazabiliriz.

A ve F Hücreleri karekter uzunluğu 3 ise mizandan getirsin. değilse işlem yapmasın.