AlbertLind
01-12-2022, 11:18 AM
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.
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.