How can I move the location of a pivot table in order to ensure it will not overlap with another pivot table below on refresh?
I have 10 pivot tables whose column span is always equal to
The rows will dynamically update as the pivots refresh.
I want there to be 2 blank rows before each new pivot table starts so I am using the following workaround
(other questions indicate you cannot directly insert rows as a pivot table refreshes to stop them from overlapping which is the root problem I am trying to curb/workaround)
- Disable auto-calculation
- Loop through all pivots (
- Offset pivot by
(LRow, 6)…. New column span is now
- Refresh Pivot (which will update
LRowon next loop as the table resizes)
- Next Pivot
- Re-enable auto-calculate & delete Columns
A:Fwhich means the pivots will be back in their original starting point spanning columns
A:Ewhile leaving 2 empty rows in-between each pivot.
The problem is with
pvt.PivotTableWizard TableDestination:=Range("G" & lrow) which does not move the pivot table (or appear to do anything).
Sub MovePivots() Dim pvt As PivotTable, LRow As Long Application.Calculation = xlCalculationManual For Each pvt In PivotTables LRow = Range("G" & Rows.Count).End(xlUp).Offset(2).Row pvt.PivotTableWizard TableDestination:=Range("G" & LRow) pvt.PivotCache.Refresh Next pvt Application.Calculation = xlCalculationAutomatic Range("A:F").EntireColumn.Delete End Sub
As an alternative to moving PivotTables before the refresh to avoid errors, how about another route: Refresh the Pivots, see if an error occurs, and then move the ones that overlap as a result.
Here’s some code I wrote some time back to identify overlaps, if you elect to go down this route.
Sub FindPivotOverlaps() Dim ws As Worksheet Dim pt As PivotTable Dim pt2 As PivotTable Dim lo As ListObject Dim rOffset As Range Dim cell As Range Dim sMsg As String For Each ws In ActiveWorkbook.Worksheets For Each pt In ws.PivotTables With pt.TableRange2 Set rOffset = Union( _ .Offset(pt.TableRange2.Rows.Count, 0).Resize(1), _ .Offset(0, pt.TableRange2.Columns.Count).Resize(pt.TableRange2.Rows.Count, 1)) End With 'Test for ListObject collision Set lo = Nothing On Error Resume Next Set lo = rOffset.ListObject On Error GoTo 0 If Not lo Is Nothing Then sMsg = sMsg & lo.Name & vbTab & "'" & lo.Parent.Name & "'!" & lo.DataBodyRange.Address & vbNewLine Else 'Test for PivotTable collision For Each cell In rOffset Set pt2 = Nothing On Error Resume Next Set pt2 = cell.PivotTable On Error GoTo 0 If Not pt2 Is Nothing Then sMsg = sMsg & pt2.Name & vbTab & "'" & pt2.Parent.Name & "'!" & pt2.TableRange2.Address & vbNewLine Exit For End If Next cell End If Next pt Next ws If sMsg = "" Then sMsg = "No overlaps found!" MsgBox sMsg End Sub
PivotTable.PivotTableWizardMethod creates and returns a
PivotTableobject – you can’t use it to loop through existing pivot tables and move them.
PivotTable.TableRange2Property returns a
Rangeobject that represents the range containing the entire PivotTable report, including page fields.
I took a slightly different approach:
- Insert 5 new columns to move all pivot tables to the right
- Loop through all the pivot tables,
Cutting them and moving to Column A and then refreshing.
In testing, Excel did not necessarily work from top to bottom, and my pivot tables were thrown out of order. In that case, you could create an Array of their names and loop through them that way.
Sub RefreshPivotsAvoidingOverlap() Dim pvt As PivotTable Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") Dim lRow As Long ws.Columns("A:E").Insert For Each pvt In ws.PivotTables lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row + 3 With pvt.TableRange2 .Cut ws.Cells(lRow, 1) pvt.PivotCache.Refresh End With Next pvt End Sub
What I ended up using:
This will refresh pivots while keeping the desired location & spacing between each pivot without throwing an error due to overlapping. To control the order that the pivots are handle, use an array (enter the pivot table names in the order in wish you want them to be handled).
With screen updating toggled off, it just looks like the pivots are refreshing while dynamically adding/removing rows to keep desired spacing.
Option Explicit Sub Refresh_Pivots() Dim OTC As Worksheet: Set OTC = ThisWorkbook.Sheets("OTC") Dim LRow As Long, i As Long, Pvts Pvts = Array("PivotTable1", "PivotTable2", "PivotTable3", "PivotTable4", "PivotTable5") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For i = LBound(Pvts) To UBound(Pvts) LRow = OTC.Range("N" & OTC.Rows.Count).End(xlUp).Offset(3).Row OTC.PivotTables(Pvts(i)).TableRange2.Cut OTC.Range("M" & LRow) OTC.PivotTables(Pvts(i)).PivotCache.Refresh Next i Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True OTC.Range("B:L").EntireColumn.Delete End Sub
Thanks @BigBen & @jeffreyweir for useful solutions/comments/links