数据透视表重叠 VBA

Question

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 Function

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

小更新，有人可以帮我扭转这种函数和宏的组合，以便在发现重叠的数据透视表时可以插入行直到被修复，然后移动到下一个数据透视表？

提到有许多页面，每个页面都有许多枢轴，并且每天都会完成。

提前谢谢你！

Answer 1

这篇博文包含解决您问题的代码：http://erlandsendata.no/?p=3733

Answer 2

所以这段代码根本不会调整表格的位置，它只会循环遍历工作簿中的所有工作表，刷新和透视表。 我建议您移动数据透视表（此操作不需要 vba，只需在 excel 中移动表格即可）。