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中移动表）。

数据透视表重叠VBA

2 个答案: