Tworzenie tabeli przestawnej przez VBA

Moim zdaniem nagranie makra tworzącego tabelę przestawną nie jest dobrym rozwiązaniem. Pierwszy problem pojawia się, gdy chcemy ponownie uruchomić kod by dodać następną tabelę – nie uda nam się dodać tabeli przestawnej pod tą samą nazwą.

Po przeszukaniu internetu znalazłem parę stron, gdzie zostały pokazane przykłady na dodanie tabeli przestawnej przez kod VBA.

Źródło:
https://www.thespreadsheetguru.com/blog/2014/9/27/vba-guide-excel-pivot-tables
https://www.mrexcel.com/forum/excel-questions/672212-vba-macro-generate-pivot-table-display-sum-field-instead-count.html#post3330709
https://answers.microsoft.com/en-us/msoffice/forum/msoffice_access-mso_other/unable-to-set-the-function-property-of-the-pivot/73aeead5-d9a9-4ddc-adbb-fa2605e5a8b6?auth=1
http://www.contextures.com/excel-vba-pivot-format-macro.html
https://stackoverflow.com/questions/24170895/pivottable-do-not-show-subtotals

' Source:
' https://www.thespreadsheetguru.com/blog/2014/9/27/vba-guide-excel-pivot-tables
' https://www.mrexcel.com/forum/excel-questions/672212-vba-macro-generate-pivot-table-display-sum-field-instead-count.html#post3330709
' https://answers.microsoft.com/en-us/msoffice/forum/msoffice_access-mso_other/unable-to-set-the-function-property-of-the-pivot/73aeead5-d9a9-4ddc-adbb-fa2605e5a8b6?auth=1
' http://www.contextures.com/excel-vba-pivot-format-macro.html
' https://stackoverflow.com/questions/24170895/pivottable-do-not-show-subtotals

Public Sub CreatePivot()

Dim sht As Worksheet
Dim pvtCache As PivotCache
Dim pvt As PivotTable
Dim StartPvt, PivotSheet, TempName  As String
Dim SrcData As String
Dim wiersz, SheetsCount As Long
Dim pvtFld As PivotField
Dim CodeJump, Godzina, ap, DataDzisiejsza
Dim ws As Worksheet

' ---------------------------------------------------------------------------
' PRZYPISYWANIE WARTOŚCI DO ZMIENNYCH

Workbooks("FileName).Sheets("SheetName").Select
wiersz = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
DataDzisiejsza = Format(Now, "yymmdd")
Godzina = Format(Time(), "hhmmss")
ap = "'"
TempName = "PivotZakres" & Godzina

' ---------------------------------------------------------------------------
' WSTĘPNE USTAWIENIA PIVOTA

Set ws = ActiveSheet					'Określenie źródła tabeli przestawnej
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Names.Add Name:=TempName, RefersToR1C1:= _
"='" & ws.Name & ap & "!R1C1:R" & wiersz & "C20" 
Set sht = Sheets.Add					'Dodanie nowego arkusza
StartPvt = sht.Name & "!" & _ 
sht.Range("A3").Address(ReferenceStyle:=xlR1C1)		'Określenie miejsca docelowego tabeli przestawnej
Set pvtCache = ActiveWorkbook.PivotCaches.Create( _		
    SourceType:=xlDatabase, _
    SourceData:=TempName)				'Tworzenie Pivot Cache z Source Data

'Create Pivot table from Pivot Cache
  Set pvt = pvtCache.CreatePivotTable( _
    TableDestination:=StartPvt, _
    TableName:="P" & Godzina)

' ---------------------------------------------------------------------------
' DODAWANIE PIVOTA

With pvt
    ' WSTĘPNE USTAWIENIA
    .InGridDropZones = True
    .RowAxisLayout xlTabularRow
    '.TableStyle2 = ""
    .DisplayContextTooltips = False
    .ShowDrillIndicators = False
    .RepeatAllLabels xlRepeatLabels
    .NullString = ""

    ' ETYKIETA WIERSZY    
    .PivotFields("ColumnName1").Orientation = xlRowField
    .PivotFields("ColumnName2").Orientation = xlRowField

    ' ETYKIETA DANYCH
    With .PivotFields("ColumnName3")
        .Orientation = xlDataField 
        .Caption = "Coulmn3NewName"
        .Function = xlSum 
    End With

   With .PivotFields("ColumnName4")
        .Orientation = xlDataField 
        .Caption = "Coulmn4NewName"
        .Function = xlCount
    End With

    ' USUWANIE SUM CZĘŚCIOWYCH Z KAŻDEGO POLA   
    For Each pvtFld In .PivotFields
        If pvtFld = "Values" Then
            'Omniecie beldu
        Else
            pvtFld.Subtotals(1) = True
            pvtFld.Subtotals(1) = False
        End If
    Next pvtFld
End With

' ---------------------------------------------------------------------------
' NAZYWANIE ARKUSZA Z PIVOTem
    
With Workbooks(FileName)
    ' Szukanie czy arkusz z propowana nazwą istnieje
    For SheetsCount = 1 To .Sheets.Count
        If ActiveSheet.Name = "Pivot-" & DataDzisiejsza Then
            ActiveSheet.Name = "Pivot-" & DataDzisiejsza & Godzina
            GoTo CodeJump
        Else
            ' nic się nie dzieje
        End If
    Next SheetsCount
    ActiveSheet.Name = "Pivot-" & DataDzisiejsza
    
CodeJump:

    PivotSheet = ActiveSheet.Name
    .Sheets(PivotSheet).Move After:=.Sheets(Workbooks(OrginalFileName).Sheets.Count)
End With

End Sub

Dodaj komentarz

Twój adres email nie zostanie opublikowany. Wymagane pola są oznaczone *

Witryna wykorzystuje Akismet, aby ograniczyć spam. Dowiedz się więcej jak przetwarzane są dane komentarzy.