Public Sub BuildReport()
Dim ws As Worksheet
Dim shResults As Worksheet
Dim shList As Worksheet
Dim shPivot As Worksheet
Dim shCon As Worksheet
Dim pvtName As String, tblName As String
Dim lastrow As Long
Dim idxRow As Long, idxCol As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ActiveWorkbook
On Error Resume Next
.Worksheets("Results").Delete
.Worksheets("List").Delete
On Error GoTo 0
Set shList = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
shList.Name = "List"
shList.Range("A1:D1").Value = Array("Company", "Weight", "Zone", "Value")
For Each ws In .Worksheets
If ws.Name <> "List" Then
pvtName = UnpivotData(ws, shPivot)
With shPivot
.PivotTableWizard TableDestination:=.Cells(3, 1)
.PivotTables(pvtName).DataPivotField.PivotItems("Sum of Value").Position = 1
idxCol = Application.Match("Grand Total", .Rows(4), 0)
idxRow = Application.Match("Grand Total", .Columns(1), 0)
.Cells(idxRow, idxCol).ShowDetail = True
Set shCon = ActiveSheet
End With
With shCon
tblName = Replace(pvtName, "pvt", "tbl")
.ListObjects(1).Name = tblName
.Columns("A").Insert
.Range("A1").Value = "Company"
.Range("A2").Resize(.ListObjects(tblName).DataBodyRange.Rows.Count).Value = ws.Name
.ListObjects(tblName).Resize .Range("A1:D1").Resize(.ListObjects(tblName).DataBodyRange.Rows.Count)
.ListObjects(tblName).DataBodyRange.Copy
End With
With shList
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Cells(lastrow + 1, "A").PasteSpecial Paste:=xlPasteValues
End With
shPivot.Delete
shCon.Delete
End If
Next ws
Set shResults = .Worksheets.Add(.Worksheets(.Worksheets.Count))
shResults.Name = "Results"
Call CreatePivotTable(dataSource:=shList.UsedRange, _
PivotSheet:=shResults, _
PivotTableName:="pvtResults")
With shResults
With .PivotTables("pvtResults")
With .PivotFields("Weight")
.Orientation = xlRowField
.Position = 1
End With
.AddDataField .PivotFields("Value"), "Sum of Value", xlSum
End With
Call AddSlicers(PivotSheet:=shResults, _
Pivot:=.PivotTables("pvtResults"), _
SlicerField:="Company", _
pos:=Array(20, 200, 150, 200))
Call AddSlicers(PivotSheet:=shResults, _
Pivot:=.PivotTables("pvtResults"), _
SlicerField:="Zone", _
pos:=Array(20, 400, 150, 200))
End With
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Function UnpivotData( _
ByRef sh As Worksheet, _
ByRef shPivot As Worksheet) As String
Dim rng As String
Dim pvt As String
Dim firstrow As Long
Dim lastrow As Long
Dim lastcol As Long
With ActiveWorkbook
firstrow = sh.UsedRange.Cells(1, 1).Row
lastrow = sh.UsedRange.Cells(1, 1).End(xlDown).Row
lastcol = sh.UsedRange.Cells(1, 1).End(xlToRight).Column
rng = "'" & sh.Name & "'!" & "R" & firstrow & "C1:R" & lastrow & "C" & lastcol
pvt = Replace(sh.Name, " ", "_")
.PivotCaches.Create(SourceType:=xlConsolidation, _
SourceData:=rng, _
Version:=xlPivotTableVersion12).CreatePivotTable TableDestination:="", _
TableName:=pvt, _
DefaultVersion:=xlPivotTableVersion12
Set shPivot = ActiveSheet
UnpivotData = pvt
End With
End Function
Public Function CreatePivotTable( _
ByVal dataSource As Range, _
ByVal PivotSheet As Worksheet, _
ByVal PivotTableName As String, _
Optional ByVal cellStart As String = "A1")
Dim ws As Worksheet
Dim pvtCache As PivotCache
Dim pvt As PivotTable
Dim pvtStartCell As String
Dim pvtSourceData As String
With ActiveWorkbook
pvtSourceData = dataSource.Address(False, False, xlR1C1, True)
pvtStartCell = PivotSheet.Range(cellStart).Address(False, False, xlR1C1, True)
Set pvtCache = .PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:=pvtSourceData)
Set pvt = pvtCache.CreatePivotTable(TableDestination:=pvtStartCell, _
TableName:=PivotTableName)
End With
End Function
Private Function AddSlicers( _
ByRef PivotSheet As Worksheet, _
ByRef Pivot As PivotTable, _
ByVal SlicerField As String, _
ByVal pos As Variant)
Dim cache As SlicerCache
With ActiveWorkbook
Set cache = .SlicerCaches.Add(Pivot, SlicerField)
cache.Slicers.Add PivotSheet, , SlicerField, SlicerField, _
pos(0), pos(1), pos(2), pos(3)
End With
End Function