Creating Multiple Pivot tables on the same sheet using looping code??

Stubby

Board Regular
Joined
Mar 5, 2002
Messages
188
Hello Fellow VBA people

I need some help in creating multiple pivot tables on one sheet. I managed to create the following code using Bill Jelens Excellent VBA book. The code effectivly creates a seperate pivot table on the same sheet for each of the 3 regions I have ie Central, East & West.

My question is if another region is added to the database ie North is there any way create the pivot tables (which in this case would be 4) using looping code or will I have to copy and paste the existing code I have and make the necessary changes.

Any help will be gratefully appreciated.

Sub SummaryByRegion()
' page 324-325
Dim WSD As Worksheet
Dim PTCache As PivotCache
Dim PT1 As PivotTable
Dim PT2 As PivotTable
Dim PT3 As PivotTable
Dim PivItem, PivItem1, PivItem2
Dim PRange As Range
Dim FinalRow As Long

Set WSD = Worksheets("PivotTable")
Dim WSR As Worksheet
Dim WBO As Workbook
Dim WBN As Workbook
Set WBO = ActiveWorkbook

' Delete any prior pivot tables
For Each PT1 In WSD.PivotTables
PT1.TableRange2.Clear
Next PT1
WSD.Range("J1:Z1").EntireColumn.Clear

' Define input area and set up a Pivot Cache
FinalRow = WSD.Cells(Application.Rows.Count, 1).End(xlUp).Row
FinalCol = WSD.Cells(1, Application.Columns.Count). _
End(xlToLeft).Column
Set PRange = WSD.Cells(1, 1).Resize(FinalRow, FinalCol)

Set PTCache = ActiveWorkbook.PivotCaches.Add(SourceType:= _
xlDatabase, SourceData:=PRange.Address)

'*************** Create 1st Pivot Table from the Pivot Cache************
'Cells(2, FinalCol + 2)
Set PT1 = PTCache.CreatePivotTable(TableDestination:=WSD.Range("m10"), TableName:="PivotTable1")

' Turn off updating while building the table
PT1.ManualUpdate = True

' Set up the row fields
PT1.AddFields RowFields:=Array("Region", "Product"), ColumnFields:="Data"

' Define Calculated Fields
PT1.CalculatedFields.Add Name:="ProfitPercent", Formula:="=Profit/Revenue"

' yqa = PT1.RowFields.Count
' MsgBox yqa


' Set up the data fields
With PT1.PivotFields("Revenue")
.Orientation = xlDataField
.Function = xlSum
.Position = 1
.NumberFormat = "#,##0"
.Name = "Total Revenue"
End With

With PT1.PivotFields("Profit")
.Orientation = xlDataField
.Function = xlSum
.Position = 1
.NumberFormat = "#,##0"
.Name = "Total Profit"
End With

With PT1.PivotFields("ProfitPercent")
.Orientation = xlDataField
.Function = xlSum
.Position = 2
.NumberFormat = "#0.0%"
.Name = "GP Pct"
End With

For Each PivItem In PT1.PivotFields("Region").PivotItems
PivItem.Visible = True
Next PivItem

For Each PivItem In PT1.PivotFields("Region").PivotItems
Select Case PivItem.Name
Case "East"
PivItem.Visible = True
Case Else
PivItem.Visible = False
End Select
Next PivItem




' Ensure that we get zeros instead of blanks in the data area
PT1.NullString = "0"

' Calc the pivot table
PT1.ManualUpdate = False
PT1.ManualUpdate = True
'**********************************************************************************
Worksheets("PivotTable").Cells(Application.Rows.Count, "m").End(xlUp).Offset(2, 0).Select

Set PT2 = PTCache.CreatePivotTable(TableDestination:=ActiveCell, TableName:="PivotTable2")

' Turn off updating while building the table
PT2.ManualUpdate = True

' Set up the row fields
PT2.AddFields RowFields:=Array("Region", "Product"), ColumnFields:="Data"

' Define Calculated Fields
PT2.CalculatedFields.Add Name:="ProfitPercent ", Formula:="=Profit/Revenue"

' Set up the data fields
With PT2.PivotFields("Revenue")
.Orientation = xlDataField
.Function = xlSum
.Position = 1
.NumberFormat = "#,##0"
End With

With PT2.PivotFields("Profit")
.Orientation = xlDataField
.Function = xlSum
.Position = 1
.NumberFormat = "£#,##0.00"
End With

With PT2.PivotFields("ProfitPercent")
.Orientation = xlDataField
.Function = xlSum
.Position = 2
.NumberFormat = "#0.0%"
.Name = "GP Pct"
End With

For Each PivItem1 In PT2.PivotFields("Region").PivotItems
PivItem1.Visible = True
Next

For Each PivItem1 In PT2.PivotFields("Region").PivotItems
Select Case PivItem1.Name
Case "West"
PivItem1.Visible = True
Case Else
PivItem1.Visible = False
End Select
Next PivItem1




' Ensure that we get zeros instead of blanks in the data area
PT2.NullString = "0"

' Calc the pivot table
PT2.ManualUpdate = False
PT2.ManualUpdate = True
'**********************************************************************************
Worksheets("PivotTable").Cells(Application.Rows.Count, "m").End(xlUp).Offset(2, 0).Select
Set PT3 = PTCache.CreatePivotTable(TableDestination:=ActiveCell, TableName:="PivotTable3")

' Turn off updating while building the table
PT3.ManualUpdate = True

' Set up the row fields
PT3.AddFields RowFields:=Array("Region", "Product"), ColumnFields:="Data"

' Define Calculated Fields
PT3.CalculatedFields.Add Name:="ProfitPercent ", Formula:="=Profit/Revenue"

' Set up the data fields
With PT3.PivotFields("Revenue")
.Orientation = xlDataField
.Function = xlSum
.Position = 1
.NumberFormat = "#,##0"
End With

With PT3.PivotFields("Profit")
.Orientation = xlDataField
.Function = xlSum
.Position = 1
.NumberFormat = "#,##0"
End With

With PT3.PivotFields("ProfitPercent")
.Orientation = xlDataField
.Function = xlSum
.Position = 2
.NumberFormat = "#0.0%"
.Name = "GP Pct"
End With

For Each PivItem2 In PT3.PivotFields("Region").PivotItems
PivItem2.Visible = True
Next

For Each PivItem2 In PT3.PivotFields("Region").PivotItems
Select Case PivItem2.Name
Case "Central"
PivItem2.Visible = True
Case Else
PivItem2.Visible = False
End Select
Next PivItem2




' Ensure that we get zeros instead of blanks in the data area
PT3.NullString = "0"

' Calc the pivot table
PT3.ManualUpdate = False
PT3.ManualUpdate = True
'**********************************************************************************
Worksheets("PivotTable").Cells(Application.Rows.Count, "m").End(xlUp).Offset(2, 0).Select
WSD.Activate
Range("M:Q").EntireColumn.AutoFit
 

Some videos you may like

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce

Watch MrExcel Video

Forum statistics

Threads
1,127,870
Messages
5,627,366
Members
416,245
Latest member
Xterminat

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