Pivot Table Updater

[ethoros]

This Macro will update all pivot tables in a workbook and reduce the filesize if there are multiple pivot tables from the same datasource.


Sub Updatepivots()


Dim pt As PivotTable

Dim ws As Worksheet

Dim pc As PivotCache

Dim lastcache As Integer


Application.ScreenUpdating = False


On Error GoTo errorhandling

If TypeName(ActiveSheet) = "Chart" Then Worksheets(1).Activate

pr = 0

wsi = 1

For Each ws In ActiveWorkbook.Worksheets


pti = 1

For Each pt In ws.PivotTables

Application.StatusBar = "Updating Pivots... Sheet: " & wsi & "/" & ActiveWorkbook.Worksheets.Count & " " & Application.Rept(Chr(7), pti)

If pt.PivotCache.SourceType = xlExternal Then

If pr = 0 Then

Prompt = "Workbook contains references to external data" & vbNewLine & "Would you like these pivots refreshing in the update?"

extupdate = MsgBox(Prompt, vbYesNo + vbQuestion, "External Data Reference")

pr = 1

End If

For Each pc In ActiveWorkbook.PivotCaches

If pc.SourceType = xlExternal Then

If pt.PivotCache.CommandText = pc.CommandText And pt.CacheIndex <> pc.Index Then

pt.CacheIndex = pc.Index

GoTo jump

End If

End If

Next pc

GoTo jump

End If


If pt.CacheIndex = lastcache Then GoTo cached

If InStr(pt.PivotCache.SourceData, "!") = 0 Then GoTo cached

If InStr(pt.PivotCache.SourceData, "") <> 0 Then GoTo cached

If InStr(pt.PivotCache.SourceData, ".xls") <> 0 Then GoTo cached

wsname = Left(pt.PivotCache.SourceData, InStr(pt.PivotCache.SourceData, "!") - 1)

srcrow = Val(Mid(pt.PivotCache.SourceData, InStr(pt.PivotCache.SourceData, "!") + 2, 1))

wsname = Application.WorksheetFunction.Substitute(wsname, "'", "")

If Sheets(wsname).FilterMode Then Sheets(wsname).ShowAllData

If WorksheetFunction.CountA(Sheets(wsname).Cells) > 0 Then

frow = Sheets(wsname).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

End If


If Sheets(wsname).Cells(srcrow, 1) <> "" Then

srow = srcrow

Else

Sheets(wsname).Activate

Sheets(wsname).Range("a1").Select

Selection.End(xlDown).Select

srow = ActiveCell.Row

End If


fcol = Sheets(wsname).Range("iv" & srow).End(xlToLeft).Column


If Len(WorksheetFunction.Substitute(wsname, " ", "")) < Len(wsname) Then

wsname = "'" & wsname & "'"

End If


Source = wsname & "!R" & srow & "C1:R" & frow & "C" & fcol

For Each pc In ActiveWorkbook.PivotCaches

If ActiveWorkbook.PivotCaches(pc.Index).SourceData = Source Then

pt.CacheIndex = pc.Index

GoTo cached

End If

Next pc

If Source <> pt.PivotCache.SourceData Then

pt.PivotTableWizard SourceType:=pt.PivotCache.SourceType, SourceData:=Source

End If

cached:

pt.PivotCache.Refresh

jump:

If pt.PivotCache.SourceType = xlExternal And extupdate = vbYes Then

pt.PivotCache.Refresh

End If

lastcache = pt.CacheIndex

ERRjump:

pti = pti + 1

Next pt

wsi = wsi + 1

Next ws


Application.ScreenUpdating = True

ActiveWorkbook.ShowPivotTableFieldList = False

Application.CommandBars("PivotTable").Visible = False

Application.StatusBar = False


Exit Sub


errorhandling:

Application.ScreenUpdating = True

ActiveWorkbook.ShowPivotTableFieldList = False

Application.CommandBars("PivotTable").Visible = False

ws.Select

pt.TableRange1.Select

MsgBox "Error: Unable to update " & ws.Name & ":" & pt.Name & vbNewLine & vbNewLine & Error(ERR), vbCritical

Resume ERRjump:


End Sub