Raporlama Hakkında Yardım

[DEDİMSANA]

Merhaba Arkadaşlar,
Yıl bazında tutmuş olduğum excelde hazırladığım yağ sarfiyat depom var.Burada aylık olarak hangi araç,hangi ay ne kadar yağ sarf etmiş onu formül ile yapabiliriyorum ama araç sayısı çoğaldıkça excel dosyası kasma yapıyor.Bu formülü kod ile veya pivot table ile yapmak için bana yardımcı olabilecek var mı?

 

[Ziynettin]

Deneyiniz...

Sub kod()
Dim s1 As Worksheet
Set s1 = Sheets("Sayfa1")
Application.ScreenUpdating = False
Set dc = CreateObject("scripting.dictionary")
son = s1.Cells(Rows.Count, 2).End(3).Row
a = s1.Range("A1:F" & son).Value

For i = 2 To UBound(a)
    krt = UCase(Replace(Replace(Format("1." & Month(a(i, 2)) _
          , "mmmm"), "i", "İ"), "ı", "I")) & "|" & a(i, 6)
    dc(krt) = dc(krt) + a(i, 4)
Next i

Erase a
son = 0
son = s1.Cells(Rows.Count, 10).End(3).Row
a = s1.Range("J2:V" & son).Value

ReDim v(1 To UBound(a), 1 To UBound(a, 2))
For i = 2 To UBound(a)
    say = say + 1
    For j = 2 To UBound(a, 2)
        krt = a(1, j) & "|" & a(i, 1)
        If dc.exists(krt) Then
            v(say, j - 1) = dc(krt)
        Else
            v(say, j - 1) = 0
        End If
    Next j
Next i

s1.[K3].Resize(say, UBound(a, 2) - 1) = v
Application.ScreenUpdating = True
MsgBox "İşlem bitti...", vbInformation
End Sub

 

[DEDİMSANA]

Deneyiniz...

Sub kod()
Dim s1 As Worksheet
Set s1 = Sheets("Sayfa1")
Application.ScreenUpdating = False
Set dc = CreateObject("scripting.dictionary")
son = s1.Cells(Rows.Count, 2).End(3).Row
a = s1.Range("A1:F" & son).Value

For i = 2 To UBound(a)
    krt = UCase(Replace(Replace(Format("1." & Month(a(i, 2)) _
          , "mmmm"), "i", "İ"), "ı", "I")) & "|" & a(i, 6)
    dc(krt) = dc(krt) + a(i, 4)
Next i

Erase a
son = 0
son = s1.Cells(Rows.Count, 10).End(3).Row
a = s1.Range("J2:V" & son).Value

ReDim v(1 To UBound(a), 1 To UBound(a, 2))
For i = 2 To UBound(a)
    say = say + 1
    For j = 2 To UBound(a, 2)
        krt = a(1, j) & "|" & a(i, 1)
        If dc.exists(krt) Then
            v(say, j - 1) = dc(krt)
        Else
            v(say, j - 1) = 0
        End If
    Next j
Next i

s1.[K3].Resize(say, UBound(a, 2) - 1) = v
Application.ScreenUpdating = True
MsgBox "İşlem bitti...", vbInformation
End Sub

Çok teşekkür ederim.Galiba sorunum çözüldü.

 

[Korhan Ayhan]

Özet Tablo ile alternatif...

Tablonuza dinamik alan uygulaması yaptım. Tablonuza alta doğru dilediğiniz kadar satır ekleyebilirsiniz. Özet tablo bu satırları otomatik işleme alacaktır. Tabi bunun için özet tablo üzerinde sağ tıklayıp "YENİLE" komutunu çalıştırmanız gerekecektir.

 

[DEDİMSANA]

Özet Tablo ile alternatif...

Tablonuza dinamik alan uygulaması yaptım. Tablonuza alta doğru dilediğiniz kadar satır ekleyebilirsiniz. Özet tablo bu satırları otomatik işleme alacaktır. Tabi bunun için özet tablo üzerinde sağ tıklayıp "YENİLE" komutunu çalıştırmanız gerekecektir.

Korhan Bey çok teşekkür ederim.İlginiz için.Yukardaki kod işimi gördü.

 

[DEDİMSANA]

Özet Tablo ile alternatif...

Tablonuza dinamik alan uygulaması yaptım. Tablonuza alta doğru dilediğiniz kadar satır ekleyebilirsiniz. Özet tablo bu satırları otomatik işleme alacaktır. Tabi bunun için özet tablo üzerinde sağ tıklayıp "YENİLE" komutunu çalıştırmanız gerekecektir.

Alt Satıra başka bir araç eklediğimde pivot table a yazmıyor.Sanırım ben yapamadım.Yardımcı olabilirmisiniz?

 

[DEDİMSANA]

Deneyiniz...

Sub kod()
Dim s1 As Worksheet
Set s1 = Sheets("Sayfa1")
Application.ScreenUpdating = False
Set dc = CreateObject("scripting.dictionary")
son = s1.Cells(Rows.Count, 2).End(3).Row
a = s1.Range("A1:F" & son).Value

For i = 2 To UBound(a)
    krt = UCase(Replace(Replace(Format("1." & Month(a(i, 2)) _
          , "mmmm"), "i", "İ"), "ı", "I")) & "|" & a(i, 6)
    dc(krt) = dc(krt) + a(i, 4)
Next i

Erase a
son = 0
son = s1.Cells(Rows.Count, 10).End(3).Row
a = s1.Range("J2:V" & son).Value

ReDim v(1 To UBound(a), 1 To UBound(a, 2))
For i = 2 To UBound(a)
    say = say + 1
    For j = 2 To UBound(a, 2)
        krt = a(1, j) & "|" & a(i, 1)
        If dc.exists(krt) Then
            v(say, j - 1) = dc(krt)
        Else
            v(say, j - 1) = 0
        End If
    Next j
Next i

s1.[K3].Resize(say, UBound(a, 2) - 1) = v
Application.ScreenUpdating = True
MsgBox "İşlem bitti...", vbInformation
End Sub

kodu buton ile otomatik nasıl çalıştırabilirim.

 

[Korhan Ayhan]

İnceleyiniz.

https://www.excel.web.tr/threads/sayfada-buton-duegme-olusturmak-ve-makro-atamak-1-resimli-anlatim.59436/

https://www.excel.web.tr/threads/sayfada-buton-duegme-olusturmak-ve-makro-atamak-2-resimli-anlatim.136979/