VBA to create pivot tables

[Steve Saunders]

Hi all,

I'm trying to create over 200 simple pivot tables using VBA. I'm pretty new to programming, but have found lots of good tutorials so have cobbled some code together.

The code asks for a range (I use the first row of column headers), creates a new worksheet based on the value in the cell in the range, and then inserts a pivot table on the sheet that has been created. Well that is how it is supposed to work.

The code stops after it creates the first sheet and doesn't give me any error. I'm guessing that my structure/flow isn't correct. The code to create the worksheets is OK, so the problem is either in the for loop and/or the code to create the pivot table. Can anyone see where it is breaking or are there commands to debug that I can use?

Sub InsertPivotTables()
 
'Dimension variables and declare data types for new worksheets
Dim rng As Range
Dim cell As Range

'Dimension variables and declare data types for pivot tables
Dim PSheet As Worksheet
Dim DSheet As Worksheet
Dim PCache As PivotCache
Dim PTable As PivotTable
Dim PRange As Range
Dim LastRow As Long
Dim LastCol As Long

 
'Enable error handling
On Error GoTo Errorhandling
 
'Prompt for a cell range
Set rng = Application.InputBox(Prompt:="Select cell range:", _
Title:="Create worksheets", _
Default:=Selection.Address, Type:=8)
 
'Iterate through cells in selected cell range
For Each cell In rng
 
    'Check if cell is not empty
    If cell <> "" Then
 
        'Insert worksheet and name the worksheet based on cell value
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = cell

        'Pivot table code
        'Set worksheet to active sheet
        Set PSheet = Worksheets(cell)
        'Set data range - this is an existing sheet in the workbook
        Set DSheet = Worksheets("Data")

        'Define data range
        LastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
        LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
        Set PRange = DSheet.Cells(1, 1).Resize(LastRow, LastCol)

        'Define pivot cache
        Set PCache = ActiveWorkbook.PivotCaches.Create _
        (SourceType:=xlDatabase, SourceData:=PRange). _
        CreatePivotTable(TableDestination:=PSheet.Cells(2, 2), _
        TableName:=cell)

        'Insert blank pivot table
        Set PTable = PCache.CreatePivotTable _
        (TableDestination:=PSheet.Cells(1, 1), TableName:=cell)

        'Insert row fields
        With ActiveSheet.PivotTables(cell).PivotFields(cell)
            .Orientation = xlRowField
            .Position = 1
        End With
        
        'Insert data field
        With ActiveSheet.PivotTables(cell).PivotFields(cell)
            .Orientation = xlDataField
            .Function = xlSum
            .NumberFormat = "#,##0"
            .Name = "YOLO "
        End With

    End If
 
'Continue with next cell in cell range
Next cell
 
'Go here if an error occurs
Errorhandling:

End Sub

Regards,
Steve

 

[Domenic]

Okay, I've looked at it closely, and I see a couple of other problems, at least.

I'll be happy to re-write the code for you, but first I need an answer to a question.

Which header from your selection is your data field?

 

[Steve Saunders]

Okay, I've looked at it closely, and I see a couple of other problems, at least.

I'll be happy to re-write the code for you, but first I need an answer to a question.

Which header from your selection is your data field?

Thanks so much for your kind offer Domenic. Thanks to you and some other posters on this forum I found where the problem was! It took me 5 hours, but what an amazing feeling of satisfaction! The working code is below for anyone else who may want to achieve a similar task. The code is not great, but hey, we all have to start learning somewhere!

Sub InsertPivotTables()
 
'Dimension variables and declare data types for new worksheets
Dim rng As Range
Dim Cell As Range

'Dimension variables and declare data types for pivot tables
Dim PSheet As Worksheet
Dim DSheet As Worksheet
Dim PCache As PivotCache
Dim PTable As PivotTable
Dim PRange As Range
Dim LastRow As Long
Dim LastCol As Long

 
'Enable error handling
'On Error GoTo Errorhandling
 
'Prompt for a cell range
Set rng = Application.InputBox(Prompt:="Select cell range:", _
Title:="Create worksheets", _
Default:=Selection.Address, Type:=8)
 
'Iterate through cells in selected cell range

For Each Cell In rng
 
    'Check if cell is not empty
    If Cell <> "" Then
 
        'Insert worksheet and name the worksheet based on cell value
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = Cell.Value

        'Pivot table code
        'Set worksheet to active sheet
        Set PSheet = Worksheets(Cell.Value)
        'Set data range - this is an existing sheet in the workbook
        Set DSheet = Worksheets("foo")

        'Define data range
        LastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
        LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
        Set PRange = DSheet.Cells(1, 1).Resize(LastRow, LastCol)

        'Define pivot cache and create
        ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="foo!data").CreatePivotTable TableDestination:=PSheet.Cells(1, 1), _
        TableName:=Cell.Value

        'Insert row fields
        With ActiveSheet.PivotTables(Cell.Value).PivotFields(Cell.Value)
            .Orientation = xlRowField
            .Position = 1
        End With
        
        'Insert data fields
        With ActiveSheet.PivotTables(Cell.Value).PivotFields(Cell.Value)
            .Orientation = xlDataField
            .Function = xlSum
            .NumberFormat = "#,##0"
            .Name = "Frequency"
       End With

        With ActiveSheet.PivotTables(Cell.Value).PivotFields(Cell.Value)
            .Orientation = xlDataField
            .Function = xlCount
            .Calculation = xlPercentOfTotal
            .NumberFormat = "0.00%"
            .Name = "Percentage"
       End With
       
       With ActiveSheet.PivotTables(Cell.Value).PivotFields(Cell.Value)
            ActiveSheet.PivotTables(Cell.Value).GrandTotalName = "Total"
            ActiveSheet.PivotTables(Cell.Value).DisplayFieldCaptions = False
            ActiveSheet.PivotTables(Cell.Value).TableStyle2 = "PivotStyleLight19"
            ActiveSheet.PivotTables(Cell.Value).PivotFields(Cell.Value).PivotItems("(blank)").Visible = False
        End With
    End If
 
'Continue with next cell in cell range
Next Cell
 
'Go here if an error occurs
'Errorhandling:
 

End Sub

 

[Domenic]

That's great, I'm glad you were able to work it out.

Cheers!