Find PivotTable reports that overlap each other
2012-03-06 PivotTables 10 364
The error message "A PivotTable report cannot overlap another PivotTable report" has annoyed me lately, especially when you try to update PivotTables in a workbook with lots of worksheets with multiple PivotTables. Excel is not very helpful since the error message doesn't include any hints about where those conflicting PivotTables are. With the macros below you can find those conflicting PivotTables that Excel insists on keeping a secret for you. To solve the problem you need to make more space (rows/columns) between the PivotTables that overlap each other, or you can move them to separate worksheets.
Function GetPivotTableConflicts(wb As Workbook) As Collection ' returns a collection with information about pivottables that overlap or intersect each other Dim ws As Worksheet, i As Long, j As Long, strName As String If wb Is Nothing Then Exit Function Set GetPivotTableConflicts = New Collection With wb For Each ws In .Worksheets With ws strName = "[" & .Parent.Name & "]" & .Name Application.StatusBar = "Checking PivotTable conflicts in " & strName & "..." If .PivotTables.Count > 1 Then For i = 1 To .PivotTables.Count - 1 For j = i + 1 To .PivotTables.Count If OverlappingRanges(.PivotTables(i).TableRange2, .PivotTables(j).TableRange2) Then GetPivotTableConflicts.Add Array(strName, "Intersecting", _ .PivotTables(i).Name, .PivotTables(i).TableRange2.Address, _ .PivotTables(j).Name, .PivotTables(j).TableRange2.Address) Else If AdjacentRanges(.PivotTables(i).TableRange2, .PivotTables(j).TableRange2) Then GetPivotTableConflicts.Add Array(strName, "Adjacent", _ .PivotTables(i).Name, .PivotTables(i).TableRange2.Address, _ .PivotTables(j).Name, .PivotTables(j).TableRange2.Address) End If End If Next j Next i End If End With Next ws Set ws = Nothing Application.StatusBar = False End With If GetPivotTableConflicts.Count = 0 Then Set GetPivotTableConflicts = Nothing End Function Function OverlappingRanges(objRange1 As Range, objRange2 As Range) As Boolean OverlappingRanges = False If objRange1 Is Nothing Then Exit Function If objRange2 Is Nothing Then Exit Function If Not Application.Intersect(objRange1, objRange2) Is Nothing Then OverlappingRanges = True End If End Function Function AdjacentRanges(objRange1 As Range, objRange2 As Range) As Boolean AdjacentRanges = False If objRange1 Is Nothing Then Exit Function If objRange2 Is Nothing Then Exit Function With objRange1 If .Top + .Height = objRange2.Top Then AdjacentRanges = True End If If .Left + .Width = objRange2.Left Then AdjacentRanges = True End If End With With objRange2 If .Top + .Height = objRange1.Top Then AdjacentRanges = True End If If .Left + .Width = objRange1.Left Then AdjacentRanges = True End If End With End FunctionThe macro below shows how you can use the functions above.
Sub ShowPivotTableConflicts() ' creates a list with all pivottables in the active workbook that conflicts with each other Dim coll As Collection, i As Long, varItems As Variant, r As Long If ActiveWorkbook Is Nothing Then Exit Sub Set coll = GetPivotTableConflicts(ActiveWorkbook) If coll Is Nothing Then MsgBox "No PivotTable conflicts in the active workbook!", vbInformation Else Workbooks.Add ' create a new workbook Range("A1").Formula = "Worksheet:" Range("B1").Formula = "Conflict:" Range("C1").Formula = "PivotTable1:" Range("D1").Formula = "TableAddress1:" Range("E1").Formula = "PivotTable2:" Range("F1").Formula = "TableAddress2:" Range("A1").CurrentRegion.Font.Bold = True r = 1 For i = 1 To coll.Count r = r + 1 varItems = coll(i) Range("A" & r).Formula = varItems(0) Range("B" & r).Formula = varItems(1) Range("C" & r).Formula = varItems(2) Range("D" & r).Formula = varItems(3) Range("E" & r).Formula = varItems(4) Range("F" & r).Formula = varItems(5) Next i Range("A1").CurrentRegion.EntireColumn.AutoFit Range("A2").Select ActiveWindow.FreezePanes = True Range("A1").Select End If End Sub