Pivot filter by each item and copy to new sheet

[AlbertLind]

Dears,

I have a macro which worked with an older file. The macro filters a pivottable and copy the filtered values into a new sheet. This should be done for each item in the column. In the old file it was a power pivot table.

Now I adopted the macro to my new file with a simple pivot table, but it shows me now an error: application defined or object defined error.

I dont know how to solve the problem. I think it is because of the power pivot...

This is my new code: (the red line is the error)


Sub CreatePlantFiles()

Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim copyrange As Range
Dim strMsg As String
Dim namenArray() As String
Dim i As Integer
Dim oPI As PivotItem
Dim ws As Worksheet

Application.ScreenUpdating = False

ctSheet = ThisWorkbook.Sheets.Count
Set pt = ActiveSheet.PivotTables("Overview")
pt.PivotCache.Refresh
' change field as needed

Set pf = pt.PivotFields("Kostenstelle")

'' Zähler initialisieren
i = 0

For Each pi In pf.PivotItems
i = i + 1
ReDim Preserve namenArray(0 To i)
namenArray(i - 1) = pi
Next pi

For A = 1 To i

pf.VisibleItemsList = Array(pf.PivotItems(A))

Call CopyArea
CreateNewSheet (Range("B15").Value)

pf.VisibleItemsList = namenArray

Next A

pf.ClearAllFilters

Call Save

Worksheets("Overview").Select

Application.ScreenUpdating = True
End Sub

Sub CopyArea()
Dim startAreaNumber, endAreaNumber As Integer
Dim copyrangeFrom, copyrangeTo As Range

Worksheets("Overview").Select
startAreaNumber = Application.Match("Kostenstelle", Range("A:A"), 0) + 1
endAreaNumber = Application.Match("Grand Total", Range("A:A"), 0) - 1

Worksheets("User file generator").Range("A19:Q200").Value = ""

Set copyrangeFrom = Worksheets("Overview").Range("A" & startAreaNumber & ":Q" & endAreaNumber)
Set copyrangTo = Worksheets("User file generator").Range("A18:Q" & (18 + endAreaNumber - startAreaNumber))

copyrangTo.Value = copyrangeFrom.Value

Worksheets("User file generator").ListObjects("GeneratorTable").Resize Range("A17:P" & (18 + endAreaNumber - startAreaNumber))

End Sub

Sub CreateNewSheet(name As String)

Sheets("User File generator").Copy After:=Sheets(ThisWorkbook.Sheets.Count)
Sheets("User File generator (2)").name = name

End Sub

Sub Save()
Dim pfad As String
Dim wkbMappeNeu, wbkMappeAlt As Workbook
Dim intChoice As Integer
Dim strPath As String

Set wbkMappeAlt = ActiveWorkbook

'-----------------------------------------------------------------------

Application.FileDialog(msoFileDialogSaveAs).InitialFileName _
= "Q:\7. Marketing Investment\01 Actual\2019\Year End\Accruals\Tracking\Anlagenliste" & Year(Now) & "-" & Month(Now) & "-" & Day(Now) & "_PO List"

'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogSaveAs).Show
'determine what choice the user made

If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog(msoFileDialogSaveAs).SelectedItems(1)
Else
Exit Sub
End If

Set wkbMappeNeu = Workbooks.Add

wkbMappeNeu.SaveAs strPath

Call Mover3(wkbMappeNeu, wbkMappeAlt)

'displays the result in a message box
Call MsgBox("Datei erfolgreich gespeichert unter: " & strPath, vbInformation, "Save Path")
wkbMappeNeu.Save
ActiveWorkbook.Close
End Sub

Sub Mover3(ByRef wkbMappeNeu, ByRef wbkMappeAlt)
Dim BkNameOld, BkNameNew As String
Dim NumSht As Integer
Dim BegSht As Integer
Dim TotSht As Integer

TotSht = wbkMappeAlt.Sheets.Count

BegSht = ctSheet + 1

For x = BegSht To TotSht

wbkMappeAlt.Sheets(BegSht).Move After:=wkbMappeNeu.Sheets(wkbMappeNeu.Sheets.Count)
Next

Application.DisplayAlerts = False
wkbMappeNeu.Sheets("Sheet1").Delete
wkbMappeNeu.Sheets(1).Select
Application.DisplayAlerts = True
End Sub



I hope someone can help me.

Thank you in advance.

[Bob Phillips]

Can you post the workbook, should be simple with something to work on.

[Paul_Hossler]

Personally, I'd start with ...



ActiveSheet.PivotTables("PivotTable1").ShowPages PageField:="AAA"


... as the core VBA which generates a filtered PT on a separate WS for each visible value of the page field

You'd need to delete any existing worksheets first and format the results afterwards but that's easy


29304

[Paul_Hossler]

Something like this




Option Explicit


Sub MakeSheets()
Dim oPivotTable As PivotTable
Dim oPageField As PivotField
Dim oPageItem As PivotItem
Dim aryPageItems() As String
Dim cntPageItems As Long, idxPageItems As Long


If ActiveSheet.PivotTables.Count = 0 Then Exit Sub
Set oPivotTable = ActiveSheet.PivotTables(1)

If oPivotTable.PageFields.Count = 0 Then Exit Sub
Set oPageField = oPivotTable.PageFields(1)


For Each oPageItem In oPageField.PivotItems
With oPageItem
If .Visible Then
cntPageItems = cntPageItems + 1
ReDim Preserve aryPageItems(1 To cntPageItems)
aryPageItems(cntPageItems) = .Value
End If
End With
Next


' Application.ScreenUpdating = False


On Error Resume Next
Application.DisplayAlerts = False
For idxPageItems = LBound(aryPageItems) To UBound(aryPageItems)
Worksheets(aryPageItems(idxPageItems)).Delete
Next idxPageItems
Application.DisplayAlerts = True
On Error GoTo 0

oPivotTable.ShowPages PageField:=oPageField.Value


For idxPageItems = LBound(aryPageItems) To UBound(aryPageItems)
With Worksheets(aryPageItems(idxPageItems))
.Activate

Application.StatusBar = ActiveSheet.Name

DoEvents

.PivotTables(1).TableRange2.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

.Cells(1, 1).Resize(oPivotTable.PageFields.Count + 1, 1).EntireRow.Delete

.Range("A2").Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True

.Cells(1, 1).CurrentRegion.Rows(1).Interior.ColorIndex = 15
.Cells(1, 1).CurrentRegion.Font.Bold = True
End With
Next idxPageItems

Application.StatusBar = False
Application.ScreenUpdating = True


MsgBox "Done"

End Sub