Farklı sayfadaki verileri son sayfada dönemsel olarak toplamak

[caca85]

Merhabalar;

Ekteki dosyada 3 adet sayfanın dönemsel toplamını, makronun kendi oluşturacağı yeni sayfada (bu ekteki "TOPLAM" adındaki bir sayfa gibi) ekteki gibi bir formatta toplamasını istiyorum.Bu ekteki örnek 3 adet sayfa içeriyor ancak bu gerçek dökümanımda çok daha fazla sayfa içeriyor ve daha da artabilir.Makro yazmaya yeni başladım sayılır ve asıl dökümanımda belli bir aşamaya geldikten sonra raporun final bölümü olan bu kısmında takıldım.Yardımcı olabilirseniz bunu kendi dökümanıma uyarlamak istiyorum.

Gerçek dökümanımda yaklaşık 4 yıllık bir veri,örnektekinden farklı olarak yaklaşık 40 sütun, 12 ayrı şantiye var ve bu firmada çalıştığım sürece daha da devam edecek.

Yardımlarınız için şimdiden teşekkür ederim.

 

[Ömer BARAN]

Merhaba, foruma hoşgeldiniz.

Aşağıdaki şekilde sonuç alabilirsiniz.
(kısmen formül kullanarak sonuç üretilmektedir)

-- Belgeniz açıkken ALT+F11 tuşlarına basarak VBA ekranının görüntülenmesini sağlayın.
-- VBA ekranında üstteki menü kısmından INSERT=>MODULEyi seçin.
-- Sağ taraftaki boş alana aşağıdaki kod'u yapıştırın.
-- OK tuşlarını kullanarak, imlecin Sub BARAN satırına gelmesini sağlayın ve F5 tuşuna basın.

Not: Dönemsel toplamları alınacak sayfalarda B:E sütun aralığındaki verilerin SAYI olduğundan emin olun.
.

[B]Sub BARAN()[/B]
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Set wf = Application.WorksheetFunction
On Error GoTo 10
Application.DisplayAlerts = False
Sheets("TOPLAM").Delete
Application.DisplayAlerts = True
10
Sheets.Add After:=ActiveSheet: ActiveSheet.Name = "TOPLAM"
Set t = Sheets("TOPLAM"): t.Cells.ClearContents
kilk = CDate("31.12.9999"): kson = CDate("01.01.1900")
For s = 1 To Sheets.Count
If Sheets(s).Name <> "TOPLAM" Then
    With Sheets(s)
        .Activate: Sheets(s).[F1] = 1: .[F1].Copy
        .Range("B2:E" & Sheets(s).Range("A" & Rows.Count).End(3).Row).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply, SkipBlanks:=False, Transpose:=False
        .[F1] = "": .[A1].Activate
        If wf.Max(.[A:A]) > kson Then kson = wf.Max(.[A:A])
        If wf.Min(.[A:A]) < kilk Then kilk = wf.Min(.[A:A])
    End With
End If
Next
ilkba = CDate(wf.EoMonth(kilk, -1) + 1): ilkbs = CDate(wf.EoMonth(kilk, 0))
adet = Evaluate("=DATEDIF(" & kilk & "," & kson & ",""m"")"): t.Activate

For satır = 1 To adet + 1
sat = Sheets("TOPLAM").[A65536].End(3).Row + 3
atar = wf.EoMonth(ilkba, satır - 2) + 1
btar = wf.EoMonth(ilkbs, satır - 1)

t.Cells(sat, 1) = Format(atar, "mmmm / yyyy")
    For syf = 1 To Sheets.Count
        If Sheets(syf).Name <> "TOPLAM" Then
            sson = Sheets(syf).Cells(Rows.Count, 1).End(3).Row
            With Sheets(syf)
            t.[B1].Formula = "=SUMPRODUCT((" & .Name & "!A2:A" & sson & "<>"""") * (" & .Name & "!A2:A" & sson & ">=" & _
                    atar & ") * (" & .Name & "!A2:A" & sson & "<=" & btar & ") * (" & .Name & "!B2:B" & sson & "))"
            t.Cells(sat, 2) = Cells(sat, 2) + [B1]
                    
            t.[C1].Formula = "=SUMPRODUCT((" & .Name & "!A2:A" & sson & "<>"""") * (" & .Name & "!A2:A" & sson & ">=" & _
                    atar & ") * (" & .Name & "!A2:A" & sson & "<=" & btar & ") * (" & .Name & "!C2:C" & sson & "))"
            t.Cells(sat, 3) = Cells(sat, 3) + [C1]
                    
            t.[D1].Formula = "=SUMPRODUCT((" & .Name & "!A2:A" & sson & "<>"""") * (" & .Name & "!A2:A" & sson & ">=" _
                    & atar & ") * (" & .Name & "!A2:A" & sson & "<=" & btar & ") * (" & .Name & "!D2:D" & sson & "))"
            t.Cells(sat, 4) = Cells(sat, 4) + [D1]
                    
            t.[E1].Formula = "=SUMPRODUCT((" & .Name & "!A2:A" & sson & "<>"""") * (" & .Name & "!A2:A" & sson & ">=" & _
                    atar & ") * (" & .Name & "!A2:A" & sson & "<=" & btar & ") * (" & .Name & "!E2:E" & sson & "))"
            t.Cells(sat, 5) = Cells(sat, 5) + [E1]
            End With
        End If
    Next
Next
    Range("A1:E1").ClearContents: t.Move Before:=Sheets(1)
    [B3] = "Beton Miktarı": [C3] = "Eskavatör": [D3] = "Kamyon": [E3] = "Silindir"
t.Columns("B:E").NumberFormat = "#,##0.00": t.Columns.AutoFit
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem Tamamlandı..", vbInformation, "..:: O.BARAN ::.."
[B]End Sub[/B]

 

[caca85]

Ömer Bey elinize sağlık. Yardımlarınız için tekrar çok teşekkür ederim. Tam istediğim gibi mükemmel olmuş

 

[Ömer BARAN]

Ömer Bey elinize sağlık. Yardımlarınız için tekrar çok teşekkür ederim. Tam istediğim gibi mükemmel olmuş

Önemli olan ihtiyacın görülmesi.

Kolay gelsin.
.