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

[Stubby]

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