Soru Tarihe Göre Gruplandırma

[denigma]

Merhabalar,

Ekteki dosyada Vergi dairesine yapılan ödemeler bulunmakta. Listede yapılan ödemeler Vergi Türüne ve Dönemine Göre Gruplandırılmış Durumda. Sizlere sorum acaba Ödeme Tarihlerine Göre gruplandırma yapabilir miyim? Yani ödeme tarihlerinde toplam vergi ödemesi ve vergi türleri ile gecikme zammı gruplandırması nasıl yapmam lazım?

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

 

[YUSUF44]

Aşağıdaki kodları bir modüle kopyalayıp sayfa1'de çalıştırın. ödemelerin hangi fişe ati olduğu her satırda belirtildikten sonra yeni sayfa eklenip bu sayfaya pivot tablo ile tarihe göre listeleme yapılacaktır. Pivot tabloda istediğiniz güncellemeleri yapabilirsiniz:

Sub düzenle()
Application.ScreenUpdating = False
Columns("A:E").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
[F1:J2].Copy [A1]
[F3:J3].Copy [F1]
For i = 3 To Cells(Rows.Count, "F").End(3).Row
    If Cells(i, "F") = "Vergi Kodu" Or Cells(i, "F") = "TOPLAM" Then
        Range("F" & i - 1 & ":J" & i - 1).Copy Cells(i, "A")
    Else
        Range("A" & i - 1 & ":E" & i - 1).Copy Cells(i, "A")
    End If
Next
For j = Cells(Rows.Count, "F").End(3).Row To 3 Step -1
    If Cells(j, "F") = "Vergi Kodu" Or Cells(j, "F") = "TOPLAM" Then
        Rows(j).Delete
        Rows(j - 1).Delete
    End If
Next
Rows(2).Delete
Columns("A:J").ColumnWidth = 100
Columns("A:J").AutoFit
Rows("1:" & Cells(Rows.Count, "F").End(3).Row).AutoFit
    Range("A2").Select
    ActiveWindow.FreezePanes = True
    Application.ScreenUpdating = True

    [A1].Select
    son = Cells(Rows.Count, "A").End(3).Row
    Sheets.Add before:=Sheets(1)
    
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Sayfa1!R1C1:R" & son & "C10", Version:=6).CreatePivotTable TableDestination:= _
        Sheets(1).[A1], TableName:="PivotTable2", DefaultVersion:=6
    Sheets(1).Activate
    Sheets(1).[A1].Select
    With ActiveSheet.PivotTables("PivotTable2").PivotFields("Ödeme Tarihi")
        .Orientation = xlRowField
        .Position = 1
    End With
    ActiveSheet.PivotTables("PivotTable2").PivotFields("Ödeme Tarihi").AutoGroup
    With ActiveSheet.PivotTables("PivotTable2").PivotFields("Vergi Türü")
        .Orientation = xlRowField
        .Position = 4
    End With
    With ActiveSheet.PivotTables("PivotTable2").PivotFields("Vergi Türü")
        .Orientation = xlColumnField
        .Position = 1
    End With
    ActiveSheet.PivotTables("PivotTable2").AddDataField ActiveSheet.PivotTables( _
        "PivotTable2").PivotFields("Ödenen"), "Toplam Ödenen", xlSum
    ActiveSheet.PivotTables("PivotTable2").AddDataField ActiveSheet.PivotTables( _
        "PivotTable2").PivotFields("Gecikme Zammı"), "Toplam Gecikme Zammı", xlSum
    ActiveSheet.PivotTables("PivotTable2").AddDataField ActiveSheet.PivotTables( _
        "PivotTable2").PivotFields("Kesinleşen Gecikme Zammı"), _
        "Toplam Kesinleşen Gecikme Zammı", xlSum

End Sub

 

[denigma]

Merhaba Yusuf Bey,

Çok teşekkür ederim emeğiniz için. Çok güzel bir çalışma olmuş. Yalnız şöyle bir sorun var ki Normalde ödenenler genel toplamı 284.456,35-TL iken kodu çalıştırınca 188.915,86-TL çıkıyor. Kod çalışma sırasında ise;



Hatası veriyor.

Ayrıca Pivot table da otomatik gelmiyor.

Acaba bir yerde mi yanlışlık yapıyorum..

Teşekkürler.

 

[YUSUF44]

Eğer sayfa düzeni doğru oluşmuşsa pivot tabloyu kendiniz ayarlayabilirsiniz. Önemli olan ana sayfa düzeninin makroda olduğu gibi her satırda bir veri olmak üzere tüm bilgilerin bulunduğu şekilde olması.

 

[denigma]

Sayfa Düzeninde bir sorun yok ama verileri listeye aktarırken eksik aktarıyor. Normalde ödenenler genel toplamı 284.456,35-TL iken kodu çalıştırınca 188.915,86-TL çıkıyor. Sanki verileri eksik alıyor gibi.

 

[YUSUF44]

Kod aşağıdaki gibi olmalıymış. Öncekinde farklı satırları siliyordu muhtemelen. Yalnız koda özet tabloyu eklemedim. Kendiniz ekle menüsünden ekleyebilirsiniz.:

Sub vergi()
Application.ScreenUpdating = False
Columns("A:E").Insert shift:=xlToLeft
[F1:J2].Copy [A1]
[F3:J3].Copy [F1]
son = Cells(Rows.Count, "F").End(3).Row

For i = 2 To son
    If Cells(i + 1, "F") = "Vergi Kodu" Then
        Range("F" & i & ":J" & i).Copy Cells(i, "A")
    Else
        Range("A" & i - 1 & ":E" & i - 1).Copy Cells(i, "A")
    End If
Next
[A:J].ColumnWidth = 100
Columns("A:J").AutoFit
Rows("1:" & son).AutoFit

For j = son To 2 Step -1
    If Cells(j, "F") = "TOPLAM" Then
        Rows(j & ":" & j + 2).Delete
    End If
Next
Rows("2:3").Delete
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı, Ekle menüsünden Özet Tablo Eklemeyi Unutmayın"
End Sub

 

[denigma]

Teşekkür ediyorum.

Elinize sağlık.