very new to this but I’ll try to make my question simple to understand.
I have an Excel sheet with a pivot table which I filter through the first column (sales persons names) one by one, and then copy-pasting the filtered pivot table to a new worksheet and saving it as the sales persons name.
Is it possible to get a macro to loop through the first columns filter based on values in a table (Table1) and copy the values out to a new worksheet? An example of the macro would be helpful.
Update – I’ve managed something to some degree, but it is copying the pivottable wholesale, and then trying to save a file with each row.
Sub Gen() Dim PvtTbl As PivotTable Set PvtTbl = ActiveSheet.PivotTables("PivotTable1") Dim Field As PivotField Set Field = ActiveSheet.PivotTables("PivotTable1").PivotFields("SPerson") Dim PvtItm As PivotItem Dim Range As Range Dim i As Long Dim var As Variant Application.ScreenUpdating = False For Each PvtItm In Field.PivotItems ActiveSheet.Range("$A$11").Select Selection.CurrentRegion.Select Selection.Copy Workbooks.Add ActiveSheet.Paste ActiveWorkbook.SaveAs ("C:\" & ActiveSheet.Range("$B$2") & Format(Date, "yyyy - mm") & ".xlsx") Next PvtItm Application.ScreenUpdating = True End Sub`
Where $A$11 is the pivottable and $B$2 is the name of the salesperson I want to save the file as.
Version 1 with use of loops to select pivottable items.
Version 2 using
.ShowPages method of pivottable.
I am guessing method 1 should be more efficient.
In an initial couple of runs, with nothing else running, I was surprised to see the
.ShowPages was quicker; with an average
2.398 seconds, versus version 1, which took
Caveat: This was only a few test runs for timing, and there may be differences due to my coding, but maybe worth exploring? No other optimization methods used. There are others, of course, possible.
Option Explicit Sub GetAllEmployeeSelections() Const filePath As String = "C:\Users\User\Desktop\" 'save location for new files Dim wb As Workbook Dim ws As Worksheet Dim pvt As PivotTable Set wb = ThisWorkbook Set ws = wb.Worksheets("Sheet3") Set pvt = ws.PivotTables("PivotTable1") Application.ScreenUpdating = False Dim pvtField As PivotField Dim item As Long Dim item2 As Long Set pvtField = pvt.PivotFields("SPerson") For item = 1 To pvtField.PivotItems.Count pvtField.PivotItems(item).Visible = True For item2 = 1 To pvtField.PivotItems.Count If item2 <> item Then pvtField.PivotItems(item2).Visible = False Next item2 Dim newBook As Workbook Set newBook = Workbooks.Add With newBook Dim currentName As String currentName = pvtField.PivotItems(item).Name .Worksheets(1).Name = currentName pvt.TableRange2.Copy Worksheets(currentName).Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats .SaveAs Filename:=filePath & currentName & ".xlsx" .Close End With Set newBook = Nothing Next item Application.ScreenUpdating = True End Sub
Why not leverage the
.ShowPages method of
PivotTable and have your
sPerson as the page field argument? It loops the
pagefield specified and generates a sheet for each item with that item’s value. You can then loop again the fields items and export the data to new workbooks, save, and then delete the created sheets.
It is probably a bit overkill!
Creates a new PivotTable report for each item in the page field. Each
new report is created on a new worksheet.
expression . ShowPages( PageField )
expression A variable that represents a PivotTable object.
Option Explicit 'Requires all items selected Sub GetAllEmployeeSelections2() Const filePath As String = "C:\Users\User\Desktop\" 'save location for new files Dim wb As Workbook Dim ws As Worksheet Dim pvt As PivotTable Set wb = ThisWorkbook Set ws = wb.Worksheets("Sheet3") Set pvt = ws.PivotTables("PivotTable1") Application.ScreenUpdating = False Dim pvtField As PivotField Dim item As Variant Set pvtField = pvt.PivotFields("SPerson") pvtField.ClearAllFilters pvtField.CurrentPage = "(All)" For Each item In pvtField.PivotItems item.Visible = True Next item pvt.ShowPages "Employee" For Each item In pvtField.PivotItems Dim newBook As Workbook Set newBook = Workbooks.Add With newBook .Worksheets(1).Name = item.Name wb.Worksheets(item.Name).UsedRange.Copy Worksheets(item.Name).Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats .SaveAs Filename:=filePath & item.Name & ".xlsx" .Close End With Set newBook = Nothing Next item Application.DisplayAlerts = False For Each item In pvtField.PivotItems wb.Worksheets(item.Name).Delete Next item Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub