Gün, Hafta, Ay ve Yil'a göre makro ile toplama

[tristanfermat]

Merhaba
Arkadaslar F1, F2, F3,F4 hücrelerine tabloya göre toplam sonuclari makro ile yazdirabilir misiniz?
Tesekkürler

 

[çıtır]

Aylık,Haftalık ve yıllık toplamlarda kriteriniz nedir?Hangi ayın ,Haftanın ve yılın toplamları alınaçak.

 

[tristanfermat]

Eger sütundaki tarihlerin aylari ayniysa onlar kendi arasinda toplanacak mesela C sütununda aylari ve yillari ayni olan 10 tarih kendi arasinda toplanacak(B sütunundaki degerler toplanacak). Ayni sekilde günler kendi arasinda, haftalar her ayin 01-07 araligindan baslamak üzere 08-15 ... vs.
ve yillar 2019 olanlar 2020 olanlar...

 

[çıtır]

Tümünü,F1,F2,F3,F4 yazaçak değil mi?Dosyanızda örneklendiri misiniz?

 

[tristanfermat]

Dosyada F sütunlarina gereken degerleri yazdim degerleri bugünün 22.08.2019 oldugunu düsünerek yazdim.

 

[Necdet]

Merhaba,

Aşağıdaki kodları inceleyiniz.

Sub Toplamlar()

    Dim i   As Long, _
        t(3) As Double
        
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
    
        If Cells(i, "C") = Date Then t(0) = t(0) + Cells(i, "B")
        
        If (Year(Cells(i, "C")) = Year(Date)) And _
            Application.WorksheetFunction.WeekNum(Cells(i, "C")) = Application.WorksheetFunction.WeekNum(Date) Then _
            t(1) = t(1) + Cells(i, "B")
        
        If (Year(Cells(i, "C")) = Year(Date)) And _
            Month(Cells(i, "C")) = Month(Date) Then _
            t(2) = t(2) + Cells(i, "B")
        
        If (Year(Cells(i, "C")) = Year(Date)) Then t(3) = t(3) + Cells(i, "B")
        
    Next i
    
    Range("F3").Resize(4, 1) = Application.WorksheetFunction.Transpose(t)
    
    MsgBox "Bitti...."
    
End Sub

 

[tristanfermat]

Tesekkürler istedigim sey buydu. Peki günü ayi haftayi yili ayri butonlara atayip farkli bir sayfada calistirmak istersem nasil yapmaliyim? Yani sayfa1 den butonu sececem sonuclar sayfa2 ye yansiyacak

 

[Necdet]

Merhaba,

Keşke daha önce söyleseydiniz.

    Dim i   As Long, _
        t(3) As Double, _
        sht As Worksheet
 
    Set sht = Sheets("Tabelle1")
 
    For i = 2 To sht.Cells(Rows.Count, "A").End(3).Row
 
        If sht.Cells(i, "C") = Date Then t(0) = t(0) + sht.Cells(i, "B")
     
        If (Year(sht.Cells(i, "C")) = Year(Date)) And _
            Application.WorksheetFunction.WeekNum(sht.Cells(i, "C")) = Application.WorksheetFunction.WeekNum(Date) Then _
            t(1) = t(1) + sht.Cells(i, "B")
     
        If (Year(sht.Cells(i, "C")) = Year(Date)) And _
            Month(sht.Cells(i, "C")) = Month(Date) Then _
            t(2) = t(2) + sht.Cells(i, "B")
     
        If (Year(sht.Cells(i, "C")) = Year(Date)) Then t(3) = t(3) + sht.Cells(i, "B")
     
    Next i
 
    Range("B2").Resize(4, 1) = Application.WorksheetFunction.Transpose(t)
 
    MsgBox "Bitti...."
 
End Sub

Aşağıdaki kod ile de Filter yardımıyla toplamlar alınıyor.

Sub SuzToplamAl()

    Dim i As Integer
    Dim j As Long
    Dim SonSat As Long
    Dim t(3) As Double
    Dim f
    Dim Sht As Worksheet
    
    Application.ScreenUpdating = False
    Set Sht = Sheets("Tabelle1")
    SonSat = Sht.Cells.Find("*", , , , xlByRows, xlPrevious).Row
    f = Array(1, 4, 7, 13)
    
    If Sht.AutoFilterMode = False Then Sht.Range("A1").AutoFilter
    
    For i = 0 To 3
        Sht.Range("$A$1:$C$" & SonSat).AutoFilter Field:=3, Criteria1:=Int(f(i)), Operator:=xlFilterDynamic
'        j = Cells(Rows.Count, "B").End(3).Row
        t(i) = t(i) + Sht.Range("B" & SonSat)
    Next i
    
    Range("B2").Resize(4, 1) = Application.WorksheetFunction.Transpose(t)
    
    Sht.Range("A1").AutoFilter
    Application.ScreenUpdating = True
        
  
End Sub