VBA Pivot Table Overlapping

[junkforhr]

Hi,

I've found the below code to display overlapping pivot tables, which will look at every pivot table in the file and then it will pop up messages where the overlapping pivot tables are.

Can someone please update the code to make it so I can select the sheet that to code checks (I was thinking of having a cell have the name of the sheet) and then out-put the results to a sheet called "Checking" in B5?

The reason I'm asking is, I've inherited a workbook, that has over 700 pivot tables (which are connected via powerpivot to various csv and excel files). These pivot tables are spread over 10 sheets and trying to locate the overlapping pivot tables is time consuming and hit and miss. I 've found a few manually, but there are a lot that I cannot locate manually. Also when the below code is run , it is coming up with the error Excel is waiting on for another application to complete an OLE action.

Hoping someone can update. Thanks to the person who wrote the original code.

Sub PivotCheck()
'
' PivotCheck Macro
' Running this macro will refresh all the pivot tables in the workbook.
'IF there are errors, a window will pop up and tell you which pivot table and what worksheet is causing the error.
'Why excel does not do this automatically is a mystery. Party on.
'
Dim pt As PivotTable
Dim wks As Worksheet
For Each wks In ActiveWorkbook.Worksheets
For Each pt In wks.PivotTables
On Error Resume Next
pt.PivotCache.Refresh
If Err <> 0 Then MsgBox "pivot table """ & pt.Name & """" & vbCr & _
"refresh error on " & vbCr & "worksheet """ & wks.Name & """"
Next pt
Next wks
Set pt = Nothing
Set wks = Nothing
'
End Sub

 

[mart37]

Sub PivotCheckt()
'
' PivotCheck Macro
' Running this macro will refresh all the pivot tables in the workbook.
'IF there are errors, a window will pop up and tell you which pivot table and what worksheet is causing the error.
'Why excel does not do this automatically is a mystery. Party on.
'
Dim pt As PivotTable
Dim wks As Worksheet
Dim wksC As Worksheet
Set wksC = Worksheets("Checking")
strSheetname = InputBox("Wich sheet?")
Set wks = Worksheets(strSheetname)
For Each pt In wks.PivotTables
    On Error Resume Next
    pt.PivotCache.Refresh
    If Err <> 0 Then
        lr = wksC.Range("A" & Rows.Count).End(xlUp).Row + 1
        wksC.Range("A" & lr) = "pivot table " & pt.Name & " refresh error on worksheet " & wks.Name
    End If
Next pt
Set pt = Nothing
Set wks = Nothing
'
End Sub