Errore Tabelle Pivot Sovrapposte

Question

Buongiorno, ho una cartella excel che nei mesi è cresciuto "troppo" ... con tante - troppe - pivot

Siccome analizzano dati YTD, il file da gennaio cresce di dimensione... e con esso le pivot... ogni tanto qualche pivot cresce troppo e và a "incrociare" una delle altre... con l'errore di cui in oggetto.

Ma è possibile che non ci sia un modo x sapere in automatico DOVE c'è la sovrapposizione?? E' possibile che l'unico modo sia girare tutti i singoli fogli x cercare dove è avvenuto il problema ??

Answer 1

Ciao Almargu,

Benvenuto alla Community!

Buongiorno, ho una cartella excel che nei mesi è cresciuto "troppo" ... con tante - troppe - pivot

Siccome analizzano dati YTD, il file da gennaio cresce di dimensione... e con esso le pivot... ogni tanto qualche pivot cresce troppo e và a "incrociare" una delle altre... con l'errore di cui in oggetto.

Ma è possibile che non ci sia un modo x sapere in automatico DOVE c'è la sovrapposizione?? E' possibile che l'unico modo sia girare tutti i singoli fogli x cercare dove è avvenuto il problema ??

Priva qualcosa del genere:

• Alt+F11 per aprire l'editor di VBA
• Alt+IM per inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range, RngIntersect As Range

    Dim PC As PivotCache

    Dim PT As PivotTable

    Dim ColPT As Collection

    Dim arrIn() As Variant, arrOut() As Variant

    Dim sMsg As String

    Dim UB As Long

    Dim i As Long, j As Long, k As Long, iCtr As Long

    For Each PC In ActiveWorkbook.PivotCaches

        PC.Refresh

    Next

    On Error Resume Next

    UB = UBound(arrIn)

    On Error GoTo 0

    For Each SH In ActiveWorkbook.Worksheets

    With SH

        If .PivotTables.Count > 0 Then

            Set ColPT = New Collection

            ReDim arrIn(1 To UB + .PivotTables.Count)

            For Each PT In .PivotTables

                ColPT.Add PT.TableRange1.Address(0, 0)

            Next PT

            If CBool(ColPT.Count) Then

                For i = 1 To ColPT.Count - 1

                    For j = i + 1 To ColPT.Count

                        If AreAdjacent(.Range(ColPT(i)), .Range(ColPT(j))) Then

                            k = k + 1

                            ReDim Preserve arrOut(i To k)

                            arrOut(k) = .Name & " : " & vbTab _

                                      & ColPT(i) & " / " & ColPT(j)

                        End If

                    Next j

                Next i

            End If

        End If

        End With

    Next SH

    If CBool(k) Then

        sMsg = Join(arrOut, vbNewLine)

         Call MsgBox( _

             Prompt:="Controlla le seguente paia di PivotTable per " _

                   & "la possibilita` di sovraposizione" _

                   & vbNewLine & vbNewLine _

                   & sMsg, _

             Buttons:=vbInformation, _

             Title:="REPORT")

    End If

End Sub

'--------->>

Public Function AreAdjacent(Rng1 As Range, Rng2 As Range) As Boolean

    Dim T1 As Double, T2 As Double

    Dim H1 As Double, H2 As Double

    Dim L1 As Double, L2 As Double

    Dim W1 As Double, W2 As Double

    T1 = Rng1.Top

    T2 = Rng2.Top

    H1 = Rng1.Height

    H2 = Rng2.Height

    L1 = Rng1.Left

    L2 = Rng2.Left

    W1 = Rng1.Width

    W2 = Rng2.Width

    If T1 + H1 = T2 Or _

       T2 + H2 = T1 Or _

       L1 + W1 = L2 Or _

       L2 + W2 = L1 Then

        AreAdjacent = True

    Else

        AreAdjacent = False

    End If

End Function

'<<========= 

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm
• Alt+F8 per aprire  la finestra di gestione delle macro
• Seleziona Tester | Esegui

===

Regards,

Norman