Putting It All Together

The following code listing produces the product line manager reports in a few seconds:

Sub ProductLineManagerReport() Dim WSD As Worksheet Dim WSR As Worksheet Dim WBO As Workbook Dim WBN As Workbook Dim PTCache As PivotCache Dim PT As PivotTable Dim PRange As Range Dim TotColumns() Dim FinalRow As Long Dim FinalReportRow As Long Dim FinalCol As Integer Dim i As Integer Dim GrandRow As Long Dim NoSubtotalArray As Variant

Set WBO = ActiveWorkbook

Set WSD = Worksheets("Pivot Table")

' Delete any prior pivot tables For Each PT In WSD.PivotTables

PT.TableRange2.Clear Next PT

' Define input area and set up a Pivot Cache FinalRow = WSD.Cells(65536, 1).End(xlUp).Row Set PRange = WSD.Cells(1, 1).Resize(FinalRow, 8)

Set PTCache = ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _ SourceData:=PRange.Address)

Set PT = PTCache.CreatePivotTable(TableDestination:=WSD.Range("J2"), _

TableName:="PivotTable1") PT.ManualUpdate = True ' Set up the row fields

PT.AddFields RowFields:=Array("Product", "Customer"), ColumnFields:="Region"

' Set up the data fields With PT.PivotFields("Revenue") .Orientation = xlDataField .Function = xlSum .Position = 1 .NumberFormat = "#,##0,K" End With

' Ensure that we get zeroes instead of blanks in the data area PT.NullString = "0"

' Eliminate the Grand Total Row PT.ColumnGrand = False

' Suppress the subtotals for the outer row field NoSubtotalArray = Array(False, False, False, False, False, False, False, False, False, False, False, False)

PT.PivotFields("Product").Subtotals = NoSubtotalArray

' Sort customers descending by sum of revenue PT.PivotFields("Customer").AutoSort Order:=xlDescending, Field:="Sum of Revenue"

' Manually re-sort the Regions to put West first 1 In case West does not exist, eliminate the error message On Error Resume Next

PT.PivotFields("Region").PivotItems("West").Position = 1 On Error GoTo 0

1 Calc the pivot table PT.ManualUpdate = False PT.ManualUpdate = True

' Create a New Blank Workbook with one Worksheet

Set WBN = Workbooks.Add(xlWBATWorksheet)

Set WSR = WBN.Worksheets(l)

WSR.Name = "Report"

' Set up Title for Report

.Value = "Revenue by Product and Customer" .Font.Size = 14 End With

' Copy the pivot table data to row 3 of the Report sheet 1 Use Offset to eliminate the title row of the pivot table PT.TableRange2.Offset(1, 0).Copy

WSR.[A3].PasteSpecial Paste:=xlPasteValuesAndNumberFormats

PT.TableRange2.Clear

Set PTCache = Nothing

' Fill in the Outline view in column A 1 Look for last row in column B because many rows ' in column A are blank

FinalReportRow = WSR.Range("B65536").End(xlUp).Row With Range("A3").Resize(FinalReportRow - 2, 1) With .SpecialCells(xlCellTypeBlanks)

.FormulaR1C1 = "=R[-1]C" End With .Value = .Value End With

1 Do some basic formatting

' Autofit columns, bold the headings, right-align Selection.Columns.AutoFit Range("A3").EntireRow.Font.Bold = True Range("A3").EntireRow.HorizontalAlignment = xlRight Range("A3:B3").HorizontalAlignment = xlLeft

1 Repeat rows 1-3 at the top of each page WSR.PageSetup.PrintTitleRows = "$1:$3"

0 0

Post a comment