Question

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

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

（其他问题表明您无法在数据透视表刷新时直接插入行以阻止它们重叠，这是我要解决的根本问题/解决方法）

禁用自动计算
遍历所有枢纽（pvt）
将枢轴偏移(LRow, 6)...。新列跨度现在为G:K
刷新数据透视表（它将在表调整大小时在下一个循环中更新LRow）
下一个枢轴
重新启用自动计算并删除列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

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

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

插入5个新列以将所有数据透视表移到右侧
遍历所有数据透视表，Cut将其设置并移至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提供有用的解决方案/评论/链接

数据透视表的移动位置

3 个答案:

我最终使用的内容：