Makro ile Mizan oluşturma

walabi · 22 Ağustos 2014

Koşula Bağlı Hücre Biçimlendirme

Korhan Hocam ve site müdavimleri selamlar,

Konu başlığına geçmeden önce Mizanla ile ilgili Aralıklı seçimde çalışıyor, ancak en son MsgBox iletisinde süre 1,88 saniye gibi bir şekilde görünmekte. Yani 1,59 saniye üzerinde çıkıyor. Kanımca bu düzeltilmeli die düşünüyorum. Ve Mizan ile ilgili cevabınızı da sabırsızlıkla bekliyorum.

Konu başlığına gelirsem isteyeceğim şey aslında basit kanımca ancak ben mantığını kurup çeviremedim. Basit olduğunu düşündüğüm için ayrı bir konu açarak kirlilik yaratmayayım istedim Örnek dosya da ektedir. Açıklamaları mevcut.

İstenen şey;

Bir excel sayfası için ( sayfaya ait uygulama )

A Sütunundaki uzunluk ;
1 ve SAYI ise Ak, Bk, Ck, Dk hücreleri için
Yazı Tipi Kalın, Kırmızı ve Dolgu Rengi X ( koyu uygun bir renk )

2 ve SAYI İse Ak, Bk, Ck, Dk hücreleri için
Yazı Tipi Kalın, Kırmızı ve Dolgu Rengi X ( açık uygun bir renk )

F Sütunundaki uzunluk ;
1 ve SAYI ise Fk, Gk, Hk, Ik hücreleri için
Yazı Tipi Kalın, Kırmızı ve Dolgu Rengi X ( koyu uygun bir renk )
2 ve SAYI İse Fk, Gk, Hk, Ik hücreleri için
Yazı Tipi Kalın, Kırmızı ve Dolgu Rengi X ( açık uygun bir renk )

Bunu nasıl yazdırabiliriz.

Örnekte başlatıpta devamını getiremediğim KOD şöyle,

Sub Bicimlendir()

Cells.Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With

For K = 1 To 1000

If Len(Cells(K, 1)) = 1 Then
Cells(K, 1).Interior.Color = vbBlue

End If

Next K

End Sub

Korhan Ayhan · 23 Ağustos 2014

Renklendirme için aşağıdaki kodu deneyiniz.

Kod:

Sub Renklendir()
    Dim X As Long
    
    Application.ScreenUpdating = False
    
    Cells.Interior.ColorIndex = xlNone
    Cells.Font.ColorIndex = xlAutomatic
    Cells.Font.Bold = False
    
    For X = 2 To Cells(Rows.Count, 1).End(3).Row
        If Len(Cells(X, 1)) = 1 And IsNumeric(Cells(X, 1)) Then
            Cells(X, 1).Resize(1, 4).Font.Bold = True
            Cells(X, 1).Resize(1, 4).Font.ColorIndex = 3
            Cells(X, 1).Resize(1, 4).Interior.ColorIndex = 6
        End If

        If Len(Cells(X, 1)) = 2 And IsNumeric(Cells(X, 1)) Then
            Cells(X, 1).Resize(1, 4).Font.Bold = True
            Cells(X, 1).Resize(1, 4).Font.ColorIndex = 3
            Cells(X, 1).Resize(1, 4).Interior.ColorIndex = 6
        End If
    
        If Len(Cells(X, 6)) = 1 And IsNumeric(Cells(X, 6)) Then
            Cells(X, 6).Resize(1, 4).Font.Bold = True
            Cells(X, 6).Resize(1, 4).Font.ColorIndex = 3
            Cells(X, 6).Resize(1, 4).Interior.ColorIndex = 6
        End If

        If Len(Cells(X, 6)) = 2 And IsNumeric(Cells(X, 6)) Then
            Cells(X, 6).Resize(1, 4).Font.Bold = True
            Cells(X, 6).Resize(1, 4).Font.ColorIndex = 3
            Cells(X, 6).Resize(1, 4).Interior.ColorIndex = 6
        End If
    Next

    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

walabi · 23 Ağustos 2014

Korhan Ayhan' Alıntı:

Renklendirme için aşağıdaki kodu deneyiniz.

Kod:

Sub Renklendir()
    Dim X As Long
    
    Application.ScreenUpdating = False
    
    Cells.Interior.ColorIndex = xlNone
    Cells.Font.ColorIndex = xlAutomatic
    Cells.Font.Bold = False
    
    For X = 2 To Cells(Rows.Count, 1).End(3).Row
        If Len(Cells(X, 1)) = 1 And IsNumeric(Cells(X, 1)) Then
            Cells(X, 1).Resize(1, 4).Font.Bold = True
            Cells(X, 1).Resize(1, 4).Font.ColorIndex = 3
            Cells(X, 1).Resize(1, 4).Interior.ColorIndex = 6
        End If

        If Len(Cells(X, 1)) = 2 And IsNumeric(Cells(X, 1)) Then
            Cells(X, 1).Resize(1, 4).Font.Bold = True
            Cells(X, 1).Resize(1, 4).Font.ColorIndex = 3
            Cells(X, 1).Resize(1, 4).Interior.ColorIndex = 6
        End If
    
        If Len(Cells(X, 6)) = 1 And IsNumeric(Cells(X, 6)) Then
            Cells(X, 6).Resize(1, 4).Font.Bold = True
            Cells(X, 6).Resize(1, 4).Font.ColorIndex = 3
            Cells(X, 6).Resize(1, 4).Interior.ColorIndex = 6
        End If

        If Len(Cells(X, 6)) = 2 And IsNumeric(Cells(X, 6)) Then
            Cells(X, 6).Resize(1, 4).Font.Bold = True
            Cells(X, 6).Resize(1, 4).Font.ColorIndex = 3
            Cells(X, 6).Resize(1, 4).Interior.ColorIndex = 6
        End If
    Next

    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Hocam teşekkürler, tam istediğim şekilde olmuş, sanırım bunlardan yararlanarak ben de kenarlık ayarları yapabilirim.

assenucler · 23 Ağustos 2014

Sayın walabi,

Dosyanın son halini siteye ekleyebilir misiniz?

walabi · 23 Ağustos 2014

Ekleyeceğim tabiki , ancak bir kaç rütuş yapmaya çalışmaktayım. Son şeklini verdikten sonra bu konu başlığı altına ekleyeceğim. Gün içerisinde eklemiş olurum.

walabi · 23 Ağustos 2014

assenucler' Alıntı:
Sayın walabi,

Dosyanın son halini siteye ekleyebilir misiniz?

Merhaba,

İstemiş olduğunuz dosya ektedir. Örnek bir Bilanço şablonu hazırlamaya çalışmaktayım. Şuan bitmiş durumda değil. Sadece Korhan Beyin verdiği kodları üzerine eklemiş oldum. Hesaplama adımları , tablonun son şekli henüz bitmedi.

İyi akşamlar,

assenucler · 23 Ağustos 2014

Teşekkür

İlginiz ve inceliğiniz için teşekkürler. İnşallah bitince bizlerle paylaşırsınız.

Ayrıca değerli üstatlarımızdan Korhan Ayhan'a da katkıları için teşekkürler.0

Sevgi ve saygılar.

walabi · 24 Ağustos 2014

Korhan Bey ve sayın üstadlar,

Application.ScreenUpdating = False

Application.ScreenUpdating = True

Bu iki ifadenin arasına kod yazılmakta ama ne ifade etmekte anlamış değilim. Türkçe mealini belirtebilir misiniz.

Korhan Ayhan · 24 Ağustos 2014

"False" olan satır ekran hareketlerini kapatır. "True" olan satır tekrar aktif hale getirir. Makro çalışırken ekranda oluşacak titremeleri ve hareketleri görmenizi engeller ve makronun daha hızlı çalışmasına fayda sağlar.

walabi · 24 Ağustos 2014

Korhan Hocam merhaba tekrardan .,

Bilanço çalışmam ile ilgili son bir sorum olacak. Bir döngü tasarlamaya çalıştım ancak yapamadım. Örnek Dosya son hali ile ektedir.

Yapmak istedim şey özü itibari ile alt toplam. Ben tabloya baktığımda şöylesi bir ifli yapı işimi görür diye düşünmekteyim.

Eğer A sütununun soldan iki değeri 10' a eşit ve A sütununun uzunluğu 3 ise c sütununa değer yazdır. Umarım anlatabilmişimdir. Tablo üzerinde normal hesaplamalar mevcut zaten. Daha kolay anlaşılabilir.

Tek bir döngü ile bunu yapmak mümkün müdür. Yoksa her toplam hücresi için ayrı ayrı hesaplama yaptırmak mı gerekir.

Korhan Ayhan · 25 Ağustos 2014

Aşağıdaki kodu deneyiniz.

Kod:

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("C4:C" & 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("C4:C" & 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, "C") = Evaluate("=SUMPRODUCT((LEFT(A" & X + 1 & ":A" & Son & "&""0""" & ",1)*1=A" & X & ")*(LEN(A" & X + 1 & ":A" & Son & ")=3),(C" & X + 1 & ":C" & Son & "))")
            Case 2
                Cells(X, "C") = Evaluate("=SUMPRODUCT((LEFT(A" & X + 1 & ":A" & Son & "&""0""" & ",2)*1=A" & X & ")*(LEN(A" & X + 1 & ":A" & Son & ")=3),(C" & X + 1 & ":C" & Son & "))")
        End Select
    
        If Cells(X, 2) = "AKTİF TOPLAM" Then
            Cells(X, "C") = Evaluate("=SUMPRODUCT((LEN(A4:A" & Son - 1 & ")=1)*(C4:C" & Son - 1 & "))")
        End If
    Next
    
    On Error Resume Next
    Set Alan = Range("H4:H" & 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("H4:H" & 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, "H") = Evaluate("=SUMPRODUCT((LEFT(F" & X + 1 & ":F" & Son & "&""0""" & ",1)*1=F" & X & ")*(LEN(F" & X + 1 & ":F" & Son & ")=3),(H" & X + 1 & ":H" & Son & "))")
            Case 2
                Cells(X, "H") = Evaluate("=SUMPRODUCT((LEFT(F" & X + 1 & ":F" & Son & "&""0""" & ",2)*1=F" & X & ")*(LEN(F" & X + 1 & ":F" & Son & ")=3),(H" & X + 1 & ":H" & Son & "))")
        End Select
    
        If Cells(X, 7) = "PASİF TOPLAM" Then
            Cells(X, "H") = Evaluate("=SUMPRODUCT((LEN(F4:F" & Son - 1 & ")=1)*(H4:H" & Son - 1 & "))")
        End If
    Next
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

walabi · 25 Ağustos 2014

Bilanço Örnek Dosya

Sayın Korhan Beyin destekleri ile tasarlamaya çalıştığım bilanço son hali ile ektedir. Ana hesaplar verileri bir başka dosyadan alacak şekilde ya da manuel giriş yapılacak şekilde tasarlanmıştır. Ben başka bir dosyadan veri alma şeklinde düşündüğüm için şuan aktif olmayan bir buton mevcut. Aktif ve pasifi düzeltici hesaplar için ayrı bir yol belirlenmeli. Bunun haricinde grup başlıkları makro kodlarından gelen biçimlendirme ile şekillenmektedir.

Hocam sonsuz teşekkürler.
Mizan konusu ile ilgili son aşama ile ilgili cevabınızı da sabırsızlıkla bekliyorum.

assenucler · 25 Ağustos 2014

Sayın walabi
Sayın Korhan Ayhan,

Emek ve paylaşımınız için size; büyük katkı veren değerli üstatlardan Korhan Ayhan'a ayrı ayrı teşekkürler.

Bilançoya veriler nereden aktarılıyor. Veriler ayrı bir dosyadan alınmakta ise o dosyayı da paylaşır mısınız?

Bilânço'nun "Cari Dönem" kolonuna tutarlar nasıl aktarılacaktır?

Bilgi verebilir misiniz?

Sevgi ve saygılar.

walabi · 25 Ağustos 2014

Henüz tam tam bitmedi , tam anlamıyla bitince ekleyeceğim.

Korhan Ayhan · 25 Ağustos 2014

Merhaba,

B132 hücresindeki "AKTİP TOPLAM" yazısını düzeltirseniz makrodaki sorun düzelecektir. Ben doğru yazımın "AKTİF TOPLAM" olacağını düşünerek o satır için sorguyu bu şekilde yapmıştım.

walabi · 25 Ağustos 2014

Korhan Ayhan' Alıntı:

Aşağıdaki kodu deneyiniz.

Kod:

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("C4:C" & 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("C4:C" & 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, "C") = Evaluate("=SUMPRODUCT((LEFT(A" & X + 1 & ":A" & Son & "&""0""" & ",1)*1=A" & X & ")*(LEN(A" & X + 1 & ":A" & Son & ")=3),(C" & X + 1 & ":C" & Son & "))")
            Case 2
                Cells(X, "C") = Evaluate("=SUMPRODUCT((LEFT(A" & X + 1 & ":A" & Son & "&""0""" & ",2)*1=A" & X & ")*(LEN(A" & X + 1 & ":A" & Son & ")=3),(C" & X + 1 & ":C" & Son & "))")
        End Select
    
        If Cells(X, 2) = "AKTİF TOPLAM" Then
            Cells(X, "C") = Evaluate("=SUMPRODUCT((LEN(A4:A" & Son - 1 & ")=1)*(C4:C" & Son - 1 & "))")
        End If
    Next
    
    On Error Resume Next
    Set Alan = Range("H4:H" & 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("H4:H" & 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, "H") = Evaluate("=SUMPRODUCT((LEFT(F" & X + 1 & ":F" & Son & "&""0""" & ",1)*1=F" & X & ")*(LEN(F" & X + 1 & ":F" & Son & ")=3),(H" & X + 1 & ":H" & Son & "))")
            Case 2
                Cells(X, "H") = Evaluate("=SUMPRODUCT((LEFT(F" & X + 1 & ":F" & Son & "&""0""" & ",2)*1=F" & X & ")*(LEN(F" & X + 1 & ":F" & Son & ")=3),(H" & X + 1 & ":H" & Son & "))")
        End Select
    
        If Cells(X, 7) = "PASİF TOPLAM" Then
            Cells(X, "H") = Evaluate("=SUMPRODUCT((LEN(F4:F" & Son - 1 & ")=1)*(H4:H" & Son - 1 & "))")
        End If
    Next
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Korhan Bey , son mesajınızdaki düzeltmeyi yaptım. Yani AKTİP' i AKTİF olarak değiştirdim. Haklısınız.

Yalnız üstteki kodlarda kendimce oynamalar yaptım. Asıl olması gereken hesaplamalar D ve I için olmalı. Ben kodlarda C gördüğümü D, H gördüğümü ı olarak değiştirdim.

Bu durumda grup toplamları olması gerektiği gibi hesaplanıyor. Ancak Cari dönem sütunları olan D ve I sütunları için hesaplama görünmüyor.

Kopya çekerek bunu yapabildim ancak son kısmı çözemedim sanırım. Bunu da ayarlayabilir miyiz.

Korhan Ayhan · 25 Ağustos 2014

Ben eklediğiniz örnek dosyadaki formüllü olan "C" ve "H" sütunları için kodları hazırlamıştım. Siz farklı bir uygulamamı istiyor sunuz?

walabi · 25 Ağustos 2014

Hocam C,D,H ve I sütunları için hesaplama olması gerekir. Aslında Sadece H ve I için . Sadece D ve I için olan bir formül uygulayabilir miyiz. C ve H eski veriler olacağı için sabit kalacak. D ve I ise yeni yılın verileri olacağı için asıl hesaplamaların bu sütunlar için yapılması gerekir.

Korhan Ayhan · 25 Ağustos 2014

Tabiki uygulanabilir. Aynı formüller mi uygulanacak?

walabi · 25 Ağustos 2014

Aynen hocam, C ve H için yapılan işlemler aslında D ve I sütunları için yapılmalıydı. Ben uygulanacak kodun bu sütunları da kapsayacağını düşündüğümden ayrıca belirtmemiştim.

Makro ile Mizan oluşturma

walabi

Ekli dosyalar

Korhan Ayhan

Administrator

walabi

assenucler

walabi

walabi

Ekli dosyalar

assenucler

walabi

Korhan Ayhan

Administrator

walabi

Ekli dosyalar

Korhan Ayhan

Administrator

walabi

Ekli dosyalar

assenucler

walabi

Korhan Ayhan

Administrator

walabi

Korhan Ayhan

Administrator

walabi

Korhan Ayhan

Administrator

walabi