I'm not sure if you are creating the other 32 sheets from nothing each time
you copy & paste the pivot data, or if you want to paste the data in a
certain place on each sheet, add to the previous data on the sheets, etc.
The following code should display each location in turn (hiding all the
others), and copy the first 10 rows to a new sheet. The new sheet is named
for that location. My sample pivot table has two rows of headings (most do),
and begins in cell A6. You may have to adjust the range of rows in the
Copy10Rows subroutine to match your pivot table. Also, I am copying whole
rows to the new sheets, because that was the easiest option. I don't expect
this code is exactly what you need, but it's a starting point. Let me know
how it works and what you would like it to do differently.
Option Explicit
Public Sub CopyLocation()
Dim x As Long
With ActiveSheet.PivotTables(1)
For x = 1 To .PivotFields("Location").PivotItems.Count
Call ShowItem("Product", .PivotFields("Location").PivotItems(x))
Call Copy10Rows
Next x
End With
End Sub
Private Function ShowItem(WhichFld As String, SelItem As String) As Boolean
'Declare local variables
Dim ItemFound As Boolean, x As Long, pvtItm
ItemFound = False
'Make the first pivotitem visible
Set pvtItm = ActiveSheet. _
PivotTables("PivotTable1"). _
PivotFields(WhichFld$).PivotItems(1)
pvtItm.Visible = True
'Hide every item in the pivottable that does not
'match SelItem$.
For x& = 2 To ActiveSheet. _
PivotTables("PivotTable1"). _
PivotFields(WhichFld$).PivotItems.Count
Set pvtItm = ActiveSheet. _
PivotTables("PivotTable1"). _
PivotFields(WhichFld$).PivotItems(x&)
If pvtItm = SelItem$ Then
pvtItm.Visible = True
ItemFound = True
Else
pvtItm.Visible = False
End If
Next x&
'Unless the first PivotItem matches SelItem$, hide it.
Set pvtItm = ActiveSheet. _
PivotTables("PivotTable1"). _
PivotFields(WhichFld$).PivotItems(1)
If pvtItm <> SelItem$ Then
If ItemFound = True Then
pvtItm.Visible = False
End If
Else
ItemFound = True
End If
'If no item in the pivottable matches SelItem$,
'display an error message and quit.
If ItemFound = False Then
MsgBox SelItem$ & " not found in pivot table"
ShowItem = False
Exit Function
End If
'Free object variables
Set pvtItm = Nothing
ShowItem = True
Exit Function
SIerr:
ShowItem = False
End Function
Private Sub Copy10Rows()
'Copies 10 rows of data + 1heading row from pivot table
'to a new sheet.
Dim NewSht As Worksheet, StartSht As Worksheet
On Error GoTo C10Rerr
Set StartSht = ActiveSheet
Sheets.Add
Set NewSht = ActiveSheet
StartSht.Select
'Assumes pivot table has two rows of headings (6 & 7). If we
'include row 6 in the Copy & Paste, the whole pivot table gets
'copied. Including row 7 + 10 more rows works.
Rows("7:17").Select
Selection.Copy
NewSht.Select
ActiveSheet.Paste
NewSht.Select
'Name the sheet for the value in the column A field.
NewSht.Name = NewSht.Range("A2").Value
StartSht.Select
Cleanup:
Set StartSht = Nothing
Set NewSht = Nothing
Exit Sub
C10Rerr:
MsgBox "Could not copy data", , "Copy10Rows"
GoTo Cleanup
End Sub
Hope this helps,
Hutch