Makro ile Mizan oluşturma

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Sub Toplamları_Güncelle()
    Dim Alan As Range, X As Long, Son As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    On Error Resume Next
    Set Alan = Range("D4:D" & Rows.Count).SpecialCells(xlCellTypeConstants, 16)
    On Error GoTo 0
    
    If Not Alan Is Nothing Then
        Alan.ClearContents
    End If
    
    On Error Resume Next
    Set Alan = Range("D4:D" & Rows.Count).SpecialCells(xlCellTypeFormulas, 16)
    On Error GoTo 0
    
    If Not Alan Is Nothing Then
        Alan.ClearContents
    End If
    
    Son = Cells(Rows.Count, "B").End(3).Row
    
    For X = 4 To Son
        Select Case Len(Cells(X, 1))
            Case 1
                Cells(X, "D") = Evaluate("=SUMPRODUCT((LEFT(A" & X + 1 & ":A" & Son & "&""0""" & ",1)*1=A" & X & ")*(LEN(A" & X + 1 & ":A" & Son & ")=3),(D" & X + 1 & ":D" & Son & "))")
            Case 2
                Cells(X, "D") = Evaluate("=SUMPRODUCT((LEFT(A" & X + 1 & ":A" & Son & "&""0""" & ",2)*1=A" & X & ")*(LEN(A" & X + 1 & ":A" & Son & ")=3),(D" & X + 1 & ":D" & Son & "))")
        End Select
    
        If Cells(X, 2) = "AKTİF TOPLAM" Then
            Cells(X, "D") = Evaluate("=SUMPRODUCT((LEN(A4:A" & Son - 1 & ")=1)*(D4:D" & Son - 1 & "))")
        End If
    Next
    
    On Error Resume Next
    Set Alan = Range("I4:I" & Rows.Count).SpecialCells(xlCellTypeConstants, 16)
    On Error GoTo 0
    
    If Not Alan Is Nothing Then
        Alan.ClearContents
    End If
    
    On Error Resume Next
    Set Alan = Range("I4:I" & Rows.Count).SpecialCells(xlCellTypeFormulas, 16)
    On Error GoTo 0
    
    If Not Alan Is Nothing Then
        Alan.ClearContents
    End If
    
    Son = Cells(Rows.Count, "G").End(3).Row
    
    For X = 4 To Son
        Select Case Len(Cells(X, 6))
            Case 1
                Cells(X, "I") = Evaluate("=SUMPRODUCT((LEFT(F" & X + 1 & ":F" & Son & "&""0""" & ",1)*1=F" & X & ")*(LEN(F" & X + 1 & ":F" & Son & ")=3),(I" & X + 1 & ":I" & Son & "))")
            Case 2
                Cells(X, "I") = Evaluate("=SUMPRODUCT((LEFT(F" & X + 1 & ":F" & Son & "&""0""" & ",2)*1=F" & X & ")*(LEN(F" & X + 1 & ":F" & Son & ")=3),(I" & X + 1 & ":I" & Son & "))")
        End Select
    
        If Cells(X, 7) = "PASİF TOPLAM" Then
            Cells(X, "I") = Evaluate("=SUMPRODUCT((LEN(F4:F" & Son - 1 & ")=1)*(I4:I" & Son - 1 & "))")
        End If
    Next
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[walabi]

Korhan Hocam,

Son verdiğiniz kodda ;

If Cells(X, 7) = "PASİF TOPLAM" Then
Cells(X, "I") = Evaluate("=SUMPRODUCT((LEN(F4:F" & Son - 1 & ")=1)*(H4:H" & Son - 1 & "))")
End If

Pasif tarafı ile ilgili olarak H ları I olarak değiştirdim. Ve kod bu hali ile istediğim gibi çalışmakta.

"Tümünü kopyala" kısmının nasıl yapıldığını şuan bilmediğim için bu şekilde cevap verebilmekteyim.

Teşekkürler.

 

[Korhan Ayhan]

Evet haklısınız. Son bölümü düzeltmeyi atlamışım. Bende mesajımda gerekli düzeltmeyi yaptım.

 

[walabi]

Merhaba,

Korhan Bey yardımlarınızdan dolayı çok çok teşekkür ederim. Tasarlamaya çalıştığım Örnek Bilanço uygulaması ektedir. Az olan makro bilgim ile sizin verdiğiniz kodlar üzerine birşeyler ekleyerek kendi çapımızda bir uygulama yapmış olduk. Sanırım en güzel yanı Bilanço Şablonunun asla kaybolmayacak olması.

Sayın Assenucler (Rumuzun ne olduğunu anlamadım ama ), Bilançonun son halini ekli dosyadan alabilirsiniz.

Mevcut şirketimde sistemden aldığım ham verilerden ( Muavinler ) yola çıkarak Mizan->Gelir Tablosu->Bilanço şeklinde bir sıra ile sistemden gelen raporları kontrol etmekti.

Bilanço ayağını bitirmiş durumdayım. Mizan da bitti sayılır. Sadece mümkün olacaksa Korhan beyden Mizanı hızlı hesaplayabilen bir yöntem için cevap beklemekteyim.

Bilançodaki kurgu da verileri bu mizandan ve gelir tablosundan alacak şeklindeydi. Mizandan cari dönem için veri alabiliyor. Geçmiş dönemler ise zaten kopyala yapıştır ile kolaylıkla yapılabilmekte. Sadece Gelir tablosu ayağını henüz tasarlamadım.

Site takipçilerine sevgilerle.

 

[assenucler]

Teşekkürler

Sayın walabi,


Günaydınlar ve hayırlı işler.

Sanırım Şirket'te finans - muhasebe birimindesiniz.

1998 yılında çalıştığım şirket de Oracle kullanılıyor ve çok detay listeler içinde çalışanlarımız boğuluyordu.

İşletmelerde karar verici yöneticilere; en kısa sürede mevcut verilerden anlamlı özet veriler çıkararak karşılaştırmalı temel tablolar (bilanço, gelir tablosu) ve ek mali tablolar ile bütçe öngörülen ve gerçekleşen fark analizleri raporlarını sunmak, büyük önem taşımaktadır.

Sizin çalışmanız ve sayın Korhan Ayhan’ın konuya verdiği büyük katkı, emekli bir meslek mensubu olarak ilgimi çekti ve konuyu baştan beri izlemekteyim. Size çalışmanızda başarılar ve kolaylıklar dilerim.

Kullanıcı adım; assenucler, adlarımın baş harfi ve soyadımdan oluşmaktadır.

Emek, katkı ve paylaşımda bulunan tüm dostlara içten teşekkürler.

Sevgi ve saygılar.

 

[walabi]

Merhaba,

Tasarlamaya çalıştığım şey, muavinden yani sistemden çıktısından başlayıp geri kalan tüm mali tabloları veya rapor dökümlerini excelde halletmekti. Ben de Oracle kullanmaktayım. Yaklaşık 7 senedir ve haklısınız meslekde muhasebe.

İlginize de ayrıca teşekkürler,

 

[walabi]

Korhan Bey merhaba,

Mizanın oluşturulması ile ilgili bir gelişme varmıdır acaba.

 

[walabi]

Merhaba,

Halit beye ait aşağıdaki kodlar tüm veriyi getirmekte. Bu kodu sadece değerleri getircek şekilde nasıl uyarlayabiliriz.

Sub deneme()

sat2 = Worksheets("data").Cells(Rows.Count, "b").End(3).Row + 1
Worksheets("data").Range("B2:E" & sat2).ClearContents

For i = 1 To ActiveWorkbook.Sheets.Count
If Mid(Sheets(i).Name, 1, 7) = "Muavin_" Then
'atanacak.AddItem Sheets(i).Name

sat1 = Worksheets(Sheets(i).Name).Cells(Rows.Count, "b").End(3).Row
Sheets(Sheets(i).Name).Range("B2:E" & sat1).Copy
sat2 = Worksheets("data").Cells(Rows.Count, "b").End(3).Row + 1
ActiveSheet.Paste Destination:=Worksheets("data").Range("B" & sat2)
End If
Next

sat2 = Worksheets("data").Cells(Rows.Count, "b").End(3).Row + 1

Application.CutCopyMode = False
Worksheets("data").Range("b2:e" & sat2).Sort Key1:=Worksheets("data").Range("b2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal


End Sub

 

[Korhan Ayhan]

Bu tarz işlemlerde makro kaydet yöntemi hayat kurtarır.


Boş bir excel kitabı açın
Makro kaydet işlemini başlatın. (Nereden başlatıldığını bilmiyorsanız netten arayarak bulabilirsiniz.)
Bir hücreye formül ekleyin.
Daha sonra o hücreyi kopyalayın ve değer olarak başka bir hücreye yapıştırın.

Son olarak oluşan kodları inceleyin.

Daha sonra Halit Beyin verdiği kodlara modifiye etmeye çalışın. Böylece öğrenmeye başlamış olacaksınız.

 

[hsynucn]

Teşekkürler