Pivot Table VBA

tedholly

New Member
Joined
Feb 19, 2021
Messages
17
Office Version
  1. 365
Platform
  1. Windows
I am attempting to create a code to create a pivot table on another sheet in my workbook. I am new to VBA and have been using online resources to help me piece this together.

The data sheet is Sheet 1 titled T&E

I want to run a code that will take the data from Sheet 1 (which is in a table) and put it into a new worksheet titled "Pivot Table"
I wan to create two separate pivot tables, with the attached criteria.

The first Pivot Table will be in Cell A1 and B1 on the new Sheet
The second Pivot Table will be in Cell D1 and E1

Any advice would be much appreciated.

1624910865761.png
1624910893513.png




Option Explicit

Dim wb As Workbook
Dim wsSheet1 As Worksheet, wsPT As Worksheet

Sub create_piviot_table()
Dim lastrow As Long, lastcolumn As Long
Dim datarange As Range
Dim PTCache As PivotCache
Dim PT As PivotTable
Dim pvtfield As PivotFields


Set wb = ThisWorkbook
Set wsSheet1 = ThisWorkbook.Worksheets("T&E")

Call delete_PT_Sheet

With wsSheet1
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
lastcolumn = .Cells(1, Columns.Count).End(xlToLeft).Column

Set datarange = .Range(.Cells(1, 1), .Cells(lastrow, lastcolumn))

Set wsPT = wb.Worksheets.Add
wsPT.Name = "Pivot Table"

Set PTCache = wb.PivotCaches.Create(xlDatabase, datarange)

Set PT = PTCache.CreatePivotTable(wsPT.Range("A1"), "PT_Audit")
With PT

'//Pivot Table Layout Settings
.RowAxisLayout xlTabularRow
.ColumnGrand = True
.RowGrand = False
.TableStyle2 = "pivotstylemedium9"
.HasAutoFormat = False
.SubtotalLocation xlAtBottom
End With

'Row Section
With .PivotFields("Person")
.Orientation = xlRowField
.Position = 1
End With
'Values Section
With .PivotFields("Project Number")
.Orientation = xlRowField
.Position = 2
.Function = xlCount
End With


'//releasing object memories
Set PTCache = Nothing
Set wsPT = Nothing
Set wsSheet1 = Nothing
Set wb = Nothing



End With
End Sub

Private Sub delete_PT_Sheet()

On Error Resume Next
Application.DisplayAlerts = False
wb.Worksheets("Pivot Table").Delete
Application.DisplayAlerts = True


End Sub
 

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand

JackDanIce

Well-known Member
Joined
Feb 3, 2010
Messages
9,890
Office Version
  1. 365
Platform
  1. Windows
Why recreate the pivot tables each time, why not just refresh the data if you're using the same fields and aggregations?
 

tedholly

New Member
Joined
Feb 19, 2021
Messages
17
Office Version
  1. 365
Platform
  1. Windows
Why recreate the pivot tables each time, why not just refresh the data if you're using the same fields and aggregations?
Because I have separate reports from a different excel sheet pulling data from each of the pivot tables.

This workbook gets updated weekly with new data.
 

JackDanIce

Well-known Member
Joined
Feb 3, 2010
Messages
9,890
Office Version
  1. 365
Platform
  1. Windows
Seems over complicated, could use Power Query to output the reports to those separate files, reduce amount of VBA code as well.

Not clear what the actual problem is but guessing the code doesn't work, make a copy of your workbook and then replace all of your code with below and try:
VBA Code:
Sub Create_Pivot_Table()
                
    Const sPT As String = "Pivot Table"
        
    Reset_PT_Sheet sPT
    
    With Grab_Data_Cache(ThisWorkbook.Sheets("T&E")).CreatePivotTable(Sheets(sPT).Cells(1, 1), "PT_Audit")
        '//Pivot Table Layout Settings
        .RowAxisLayout xlTabularRow
        .ColumnGrand = True
        .RowGrand = False
        .TableStyle2 = "pivotstylemedium9"
        .HasAutoFormat = False
        .SubtotalLocation xlAtBottom
        
        'Row Section
        With .PivotFields("Person")
            .Orientation = xlRowField
            .Position = 1
        End With
        
        'Values Section
        With .PivotFields("Project Number")
            .Orientation = xlRowField
            .Position = 2
            .Function = xlCount
        End With
        
    End With
    
End Sub

Private Sub Reset_PT_Sheet(sName As String)
    
    On Error Resume Next
    With Application
        .DisplayAlerts = False
        .Sheets(sName).Delete
        .DisplayAlerts = True
    End With
    On Error GoTo 0
    Sheets.Add.Name = sName

End Sub

Private Function Grab_Data_Cache(w As Worksheet) As PivotCache
    
    Dim x As Long
    Dim y As Long
    
    With w
        x = .Cells(.Rows.Count, 1).End(xlUp).Row
        y = .Cells(1, .Columns.Count).End(xlToLeft).Column
        Set Grab_Data_Cache = ThisWorkbook.PivotCaches.Create(xlDatabase, .Cells(1, 1).Resize(x, y))
    End With

End Function
 

Forum statistics

Threads
1,141,777
Messages
5,708,465
Members
421,571
Latest member
ChaosPup

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top