数据透视表的移动位置

Question

如何移动数据透视表的位置，以确保它在刷新时不会与下方的另一个数据透视表重叠？

我有 10 个数据透视表，其列跨度始终等于 A:E。
行将随着枢轴刷新而动态更新。
我希望在每个新数据透视表开始之前有 2 个空白行，所以我使用以下解决方法

（其他问题表明您不能在数据透视表刷新时直接插入行以阻止它们重叠，这是我试图遏制/解决的根本问题）

1. 禁用自动计算
2. 循环遍历所有枢轴 (pvt)
3. 将轴偏移(LRow, 6) .... 新列跨度现在是G:K
4. 刷新枢轴（将在下一个循环中更新LRow，因为表格调整大小）
5. 下一个枢轴
6. 重新启用自动计算和删除列A:F，这意味着枢轴将回到原来的起点，跨越列A:E，同时在每个枢轴之间留下2个空行。

问题在于pvt.PivotTableWizard TableDestination:=Range("G" & lrow) 不会移动数据透视表（或似乎做任何事情）。

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

Answer 1

作为在刷新之前移动数据透视表以避免错误的替代方法，另一种方法如何：刷新数据透视表，查看是否发生错误，然后移动结果重叠的数据透视表。

如果您选择沿着这条路线走，这是我一段时间前写的一些代码来识别重叠。

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

Answer 2

1. PivotTable.PivotTableWizard Method 创建并返回一个 PivotTable 对象 - 您不能使用它来遍历现有的数据透视表并移动它们。
2. PivotTable.TableRange2 Property 返回一个 Range 对象，该对象表示包含整个数据透视表（包括页面字段）的范围。

我采取了稍微不同的方法：

1. 插入 5 个新列以将所有数据透视表向右移动
2. 循环遍历所有数据透视表，Cutting 它们并移动到 A 列，然后刷新。

在测试中，Excel 不一定能从上到下工作，我的数据透视表也乱了。在这种情况下，您可以创建一个包含它们名称的数组并以这种方式遍历它们。

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

Answer 3

我最终使用了什么：

这将刷新枢轴，同时保持每个枢轴之间的所需位置和间距，而不会因重叠而引发错误。要控制数据透视表的处理顺序，请使用数组（按希望处理它们的顺序输入数据透视表名称）。

关闭屏幕更新后，看起来枢轴正在刷新，同时动态添加/删除行以保持所需的间距。

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

感谢@BigBen 和@jeffreyweir 提供有用的解决方案/cmets/链接