Public Sub SplitOut() Dim this As Worksheet Dim shTemp As Worksheet Dim pvtTemp As PivotTable Dim numrows As Long Dim ws As Worksheet Dim emp As String Dim i As Long Application.ScreenUpdating = False With ThisWorkbook Set this = ActiveSheet Set shTemp = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count)) .PivotCaches.Create(SourceType:=xlDatabase, _ SourceData:="order!R1C1:R9C5", _ Version:=xlPivotTableVersion12).CreatePivotTable _ TableDestination:=shTemp.Name & "!R1C1", _ TableName:="pvtTemp", _ DefaultVersion:=xlPivotTableVersion12 Set pvtTemp = ActiveSheet.PivotTables("pvtTemp") With pvtTemp With .PivotFields("AM Name") .Orientation = xlPageField .Position = 1 End With With .PivotFields("Order " & Chr(10) & "Date") .Orientation = xlRowField .Position = 1 .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False) End With With .PivotFields("Order Status") .Orientation = xlRowField .Position = 2 .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False) End With With .PivotFields("Source") .Orientation = xlRowField .Position = 3 .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False) End With With .PivotFields("Employee Id") .Orientation = xlRowField .Position = 4 .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False) End With .DisplayFieldCaptions = False .ShowDrillIndicators = False .RepeatAllLabels xlRepeatLabels .ColumnGrand = False .RowGrand = False .InGridDropZones = True .RowAxisLayout xlTabularRow .ShowPages PageField:="AM Name" End With For i = .Worksheets.Count To 1 Step -1 Set ws = .Worksheets(i) If Not ws Is this And Not ws Is shTemp Then With ws .Activate emp = .Name .PivotTables(1).PivotSelect "", xlDataAndLabel, True Selection.Copy Selection.Cells(1, 1).PasteSpecial Paste:=xlPasteValues .Rows("2:4").Delete Shift:=xlUp .Columns("D").Insert .Range("A1:E1").Value = Array("Order Date", "Order Status", "Source", "AM Name", "Employee Id") numrows = Application.CountIf(this.Columns("D"), emp) .Range("D2").Resize(numrows).Value = emp .Columns("A:E").AutoFit .Move ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & emp & " " & Application.VLookup(emp, this.Columns("D:E"), 2, False) ActiveWorkbook.Close SaveChanges:=False End With End If Next i Application.DisplayAlerts = False shTemp.Delete End With Application.ScreenUpdating = True End Sub