Makro ile Pivot Yapma

[KARTAL133]

Merhaba Arkadaşlar

Ekteki Calışma ile ilgili Datada olan bir tabloyu makro ile Özet sayfasına almak istiyorum.
konu ile yardımlarını rica ediyorum
Şimdi den yardımlarınız için teşekkürler

 

[KARTAL133]

yardım istiyorum

yardım istiyorum

 

[Korhan Ayhan]

Makro kaydet yöntemi ile elde ettiğim kodları biraz düzenledim.

Deneyiniz.

Sub Özet_Tablo()
    Cells.Delete
    Son = Sheets("Data").Range("A" & Rows.Count).End(3).Row
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Data!A1:K" & Son, Version:=xlPivotTableVersion10).CreatePivotTable _
        TableDestination:="Özet!R4C1", TableName:="PivotTable", DefaultVersion _
        :=xlPivotTableVersion10
    Sheets("Özet").Select
    With ActiveSheet.PivotTables("PivotTable").PivotFields("Firma Adı")
        .Orientation = xlRowField
        .Position = 1
    End With
    ActiveSheet.PivotTables("PivotTable").AddDataField ActiveSheet.PivotTables( _
        "PivotTable").PivotFields("Vade"), "Toplam Vade", xlSum
    
    With ActiveSheet.PivotTables("PivotTable")
        .PivotFields("Toplam Vade").Orientation = xlRowField
        .PivotFields("Limit").Orientation = xlRowField
        .PivotFields("Limit").Position = 3
        .PivotFields("gün").Orientation = xlColumnField
        .PivotFields("gün").Position = 1
    End With
    
    ActiveSheet.PivotTables("PivotTable").AddDataField ActiveSheet.PivotTables( _
        "PivotTable").PivotFields("Tutar"), "Toplam Tutar", xlSum
    
    ActiveSheet.PivotTables("PivotTable").PivotSelect "Vade[All;Total]", _
        xlDataAndLabel, True
    ActiveSheet.PivotTables("PivotTable").PivotFields("Vade").Subtotals = Array( _
        False, False, False, False, False, False, False, False, False, False, False, False)
    ActiveSheet.PivotTables("PivotTable").PivotSelect "'Firma Adı'[All;Total]", _
        xlDataAndLabel, True
    ActiveSheet.PivotTables("PivotTable").PivotFields("Firma Adı").Subtotals = _
        Array(False, False, False, False, False, False, False, False, False, False, False, False)
    Cells.EntireColumn.AutoFit

    MsgBox "işleminiz tamamlanmıştır.", vbInformation
End Sub

 

[KARTAL133]

Çok teşekkürler