Create detail sheets with Excel vba for each row in pivot table of two columns

Question

Hello,

I have a macro that creates a pivot table from data that could change in size. I will post the code at the bottom.

I need to add code that would create detail sheets from each row in columns C & D (avoiding the total row in 16). Any help would be greatly appreciated.

I would like the names of the detail sheets to be the name of the person (Alan Sundheimer, Bryan Enriquez, etc.) Since I'm creating two detail sheets for each person, the second detail sheet could add a 1 to the sheet name (Alan Sundheimer 1) or anything that distinguishes it from the other one.

Here is the pivot table:

Here is the code that creates the pivot table from the data:

Sub InsertPivotTable()

'Declare Variables

Dim PSheet As Worksheet

Dim DSheet As Worksheet

Dim PCache As PivotCache

Dim PTable As PivotTable

Dim PRange As Range

Dim LastRow As Long

Dim LastCol As Long

'Insert a New Blank Worksheet called "PivotTable"

On Error Resume Next

Application.DisplayAlerts = False

Worksheets("PivotTable").Delete

Sheets.Add Before:=ActiveSheet

ActiveSheet.Name = "PivotTable"

Application.DisplayAlerts = True

Set PSheet = Worksheets("PivotTable")

Set DSheet = Worksheets("JobList")

'Define Data Ranges

LastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row

LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column

Set PRange = DSheet.Cells(1, 1).Resize(LastRow, LastCol)

'Define Pivot Cache

Set PCache = ActiveWorkbook.PivotCaches.Create _

(SourceType:=xlDatabase, SourceData:=PRange). _

CreatePivotTable(TableDestination:=PSheet.Cells(3, 1), _

TableName:="PivotTable")

'Insert Blank Pivot Table

Set PTable = PCache.CreatePivotTable _

(TableDestination:=PSheet.Cells(1, 1), TableName:="PivotTable")

'Insert Row Field "Employee Type" filtering out blanks

With ActiveSheet.PivotTables("PivotTable").PivotFields("Employee Type: Mitigation Review Specialist")

.Orientation = xlRowField

.Position = 1

.PivotItems("(blank)").Visible = False

End With

'Insert Column Field "Alternative Status" filtering out blanks, billed & received

With ActiveSheet.PivotTables("PivotTable").PivotFields("Alternative Status")

.Orientation = xlColumnField

.Position = 1

.PivotItems("01. Received").Visible = False

.PivotItems("08. Billed").Visible = False

.PivotItems("(blank)").Visible = False

End With

'Insert Data Field "Claim Number" as Count, captioned "Claims"

With ActiveSheet.PivotTables("PivotTable").PivotFields("Claim Number")

.Orientation = xlDataField

.Function = xlCount

.Name = "Claims "

End With

'Format Pivot Table

ActiveSheet.PivotTables("PivotTable").ShowTableStyleRowStripes = True

ActiveSheet.PivotTables("PivotTable").TableStyle2 = "PivotStyleMedium9"

End Sub

Answer 1

Hi Andy,

I've rewritten your code a bit, because it's easier to refer and use the objects.

BTW, a "On Error Resume Next" in the main routine is a bad idea, because you did not get noticed of any error, e.g. your code creates the Pivot table twice.

I did not move the detail sheets when they are created, for me it's easier if we sort all the sheets if we're done.

All your states have a number in front, therefore IMHO it is better if we rename the detail sheets as "[EmployeeName] [Statenumber]".
In that way you can change/add states very easy.

I renamed also the table inside the detail sheet to reflect the sheet name, so if you want to use that table later for analysis you can sue the sheet name without blanks to get the table.

Andreas.

Option Explicit

Sub InsertPivotTable()
'Declare Variables
Dim PSheet As Worksheet, DSheet As Worksheet, NSheet As Worksheet
Dim PCache As PivotCache
Dim PTable As PivotTable
Dim PEmployee As PivotField, PStatus As PivotField
Dim PItem As PivotItem
Dim PRange As Range, Employee As Range, Item As Range
Dim State As Variant
Dim SName As String
Dim Table As ListObject

'Prepare
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With

'Define Data Ranges
Set DSheet = Worksheets("JobList")
Set PRange = DSheet.Range("A1").CurrentRegion

'Insert a New Blank Worksheet called "PivotTable"
If SheetExists("PivotTable") Then Sheets("PivotTable").Delete
Set PSheet = Sheets.Add(Before:=DSheet)
PSheet.Name = "PivotTable"

'Define Pivot Cache
Set PCache = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PRange)
'Insert Blank Pivot Table
Set PTable = PCache.CreatePivotTable(TableDestination:=PSheet.Range("A3"), TableName:="PivotTable")

With PTable
'Insert Row Field "Employee Type" filtering out blanks
Set PEmployee = .PivotFields("Employee Type: Mitigation Review Specialist")
With PEmployee
.Orientation = xlRowField
.PivotItems("(blank)").Visible = False
End With

'Insert Column Field "Alternative Status" filtering out blanks, billed & received  
Set PStatus = .PivotFields("Alternative Status")  
With PStatus  
  .Orientation = xlColumnField  
  .PivotItems("01. Received").Visible = False  
  .PivotItems("08. Billed").Visible = False  
  .PivotItems("(blank)").Visible = False  
End With  

'Insert Data Field "Claim Number" as Count, captioned "Claims"  
With .PivotFields("Claim Number")  
  .Orientation = xlDataField  
  .Function = xlCount  
  .Name = "Claims"  
End With  

'Format Pivot Table  
.ShowTableStyleRowStripes = True  
.TableStyle2 = "PivotStyleMedium9"  

'Create the detail sheets  
For Each State In Array("03. Placed in Review", "04. Negotiations Open")  
  Set PItem = PStatus.PivotItems(State)  
  For Each Item In PItem.DataRange  
    Set Employee = Intersect(PEmployee.DataRange, Item.EntireRow)  
    SName = ValidSheetName(Employee & " " & Left(PItem.Name, 2))  
    If SheetExists(SName) Then Sheets(SName).Delete  
    Item.ShowDetail = True  
    DoEvents  
    ActiveSheet.Name = SName  
    Set Table = ActiveSheet.ListObjects(1)  
    Table.Name = ValidTableName(SName)  
  Next  
Next  

End With

'Sort the sheets
SortSheets xlAscending, Array(DSheet.Name, PSheet.Name)

'Finish
PSheet.Select
PSheet.Range("A1").Select
With Application
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

Private Function ValidSheetName(ByVal SheetName As String) As String
'Removes invalid chars from Sheetname
Const InvalidChars = ":/?*[]"
Dim i As Integer
For i = 1 To Len(InvalidChars)
SheetName = Replace(SheetName, Mid(InvalidChars, i, 1), "")
Next
ValidSheetName = Mid(SheetName, 1, 31)
End Function

Private Function ValidTableName(ByVal TableName As String) As String
'Removes invalid chars from TableName
Const InvalidChars = ":/?*[] "
Dim i As Integer
For i = 1 To Len(InvalidChars)
TableName = Replace(TableName, Mid(InvalidChars, i, 1), "")
Next
ValidTableName = Mid(TableName, 1, 255)
End Function

Private Function SheetExists(ByVal SheetNameOrIndex As Variant, Optional ByVal Wb As Workbook = Nothing) As Boolean
'True if sheet SheetNameOrIndex exists
On Error Resume Next
If Wb Is Nothing Then Set Wb = ActiveWorkbook
SheetExists = Not Wb.Sheets(SheetNameOrIndex) Is Nothing
End Function

Private Sub SortSheets(Optional SortOrder As XlSortOrder = xlAscending, _
Optional SortToLeft, Optional SortToRight)
'Sorts the worksheets by SortToLeft/SortToRight and _
others in the middle alphabetically by name
Dim i As Integer, j As Integer
Dim SaveSelectedSheets, SaveScreenUpdating, SaveEnableEvents

With Application
SaveScreenUpdating = Application.ScreenUpdating
Application.ScreenUpdating = False
SaveEnableEvents = Application.EnableEvents
Application.EnableEvents = False
End With
Set SaveSelectedSheets = ActiveWindow.SelectedSheets

For i = 1 To Sheets.Count
For j = i + 1 To Sheets.Count
If (StrComp(Sheets(j).Name, Sheets(i).Name, vbTextCompare) < 0) = _
(SortOrder = xlAscending) Then
If Sheets(j).Visible = xlSheetVisible Then
If SortOrder = xlAscending Then Sheets(j).Move Before:=Sheets(i)
End If
End If
Next
Next

On Error Resume Next
Select Case TypeName(SortToLeft)
Case "Variant()"
For i = UBound(SortToLeft) To LBound(SortToLeft) Step -1
If Sheets(CStr(SortToLeft(i))).Visible = xlSheetVisible Then
Sheets(CStr(SortToLeft(i))).Move Before:=Sheets(1)
End If
Next
Case "String"
If Sheets(CStr(SortToLeft)).Visible = xlSheetVisible Then _
Sheets(CStr(SortToLeft)).Move Before:=Sheets(1)
End Select

Select Case TypeName(SortToRight)
Case "Variant()"
For i = LBound(SortToRight) To UBound(SortToRight)
If Sheets(CStr(SortToRight(i))).Visible = xlSheetVisible Then
Sheets(CStr(SortToRight(i))).Move After:=Sheets(Sheets.Count)
End If
Next
Case "String"
If Sheets(CStr(SortToRight)).Visible = xlSheetVisible Then _
Sheets(CStr(SortToRight)).Move After:=Sheets(Sheets.Count)
End Select

SaveSelectedSheets.Select
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
ActiveWindow.ScrollWorkbookTabs SaveSelectedSheets.Item(1).Index - 1
With Application
Application.ScreenUpdating = SaveScreenUpdating
Application.EnableEvents = SaveEnableEvents
End With
End Sub

Answer 2

It is far too complicated to recreate such a scenario. And if it does not match yours, then our solution will not work for you.

For this kind of requests, please create a sample file with the layout of your original file, filled with sample data and colored cells with the expected result.

At best make a copy of your original file and anonymize the necessary data. For this please download this file
https://www.dropbox.com/s/rkfxuh85j5wyj9y/modAnonymize.bas?dl=1
Open your Excel file
Right-click on the sheet tab
Choose "View Code"
Press CTRL-M
Select the downloaded file and import
Close the VBA editor
Select the cells with the confidential data
Press Alt-F8
Choose the macro Anonymize
Click Run

Upload it on OneDrive (or an other Online File Hoster of your choice) and post the download link here.
https://support.office.com/en-us/article/Share-OneDrive-files-and-folders-9fcc2f7d-de0c-4cec-93b0-a82024800c07

Then we can look at the file and try to find a solution. Thank you for your understanding.

Andreas.

Answer 3

The link to the file is: https://1drv.ms/x/s!AqI2uIovxYp5-hwV2ewSQ7l2iJxy?e=EtZsZd

The pivot table cells marked in yellow and orange are the ones that I want to create detail sheets for. I created the first yellow and orange detail sheets.

The new detail sheets should use the same name as in column A (colored in green). Because there are two detail sheets (yellow & orange) associated with the same name (green), the second detail sheet's name should add a 1 to the end of the name.

Because there are 11 names (green) in the pivot table and each has 2 detail sheets, there should be 22 detail sheets when done.

The code to make the pivot table from the source data (in the JobList sheet) is called "InsertPivotTable".

I hope that this makes sense.

Thanks in advance for looking into this.

Andy

Answer 4

Hi Andreas,

This is AMAZING! I can't believe that you did so much effort for me. I really appreciate it. You taught me a lot about Excel VBA along the way as well!

Andy