EXCEL :: VBA :: PIVOTTABLE :: PIVOTCACHE :: Nettoyer le cache des TCD

oguruma · Dimanche à 16:04

Bonjour le Forum,
Etant actuellement sur un développement sur le registre du personnel avec de nombreux TCD pour tirer des KPI j'ai donc ressorti de vieilles fonctions que j'ai remis au gout du jour (j'espère plus propres) pour optimiser les TCD de l'application en cours de construction.
En effet l'application étant sujette de à nombreuses variations avec les mouvements de personnels il est donc prudent de nettoyer les caches des TCD pour ne pas traîner des informations inexistantes aux risques de fausser les KPI.

Autant donc vous en faire partager plus certaines que j'ai ajouté pour l'occasion. Celles-ci sont bien entendu perfectibles.

Dans mes TCD j'ai cru bon d'afficher la source des données, le nombre d'enregistrements de la source et le nom du TCD. Cela permet de m'y retrouver et de les documenter.

Un exemple :

1. Détecter si la cellule active est un TCD

VB:

Function isCURRENT_PIVOT_TABLE(Optional hCell As Range) As Boolean
'******************************************************************
' Est-ce un TCD ? - La cellule active est-elle sur un TCD ?
'******************************************************************
    Dim rRange As Range
    Dim pPivotTable As PivotTable
 
    '***********************************************************************
    '* On vérifier si une adresse de cellule est passée en paramètre
    '***********************************************************************
    If hCell Is Nothing Then Set rRange = ActiveCell Else Set rRange = hCell
 
    isCURRENT_PIVOT_TABLE = False
 
    '***********************************************************************
    '* On force le passage pour récupérer Nothing si ce c'est pas un TCD
    '***********************************************************************
    On Error Resume Next
 
    Set pPivotTable = rRange.PivotTable
    If Not pPivotTable Is Nothing Then isCURRENT_PIVOT_TABLE = True
End Function

2. Récupérer le nom du TCD

VB:

Function getCURRENT_PIVOTTABLE_NAME(Optional hCell As Range) As Variant
'******************************************************************
' Nom du TCD
'******************************************************************
    Dim rRange As Range
    Dim pPivotTable As PivotTable
 
    '***********************************************************************
    '* On vérifier si une adresse de cellule est passée en paramètre
    '***********************************************************************
    If hCell Is Nothing Then Set rRange = ActiveCell Else Set rRange = hCell
 
    getCURRENT_PIVOTTABLE_NAME = CVErr(xlErrNA)
 
    '***********************************************************************
    '* On force le passage
    '***********************************************************************
    On Error Resume Next
 
    Set pPivotTable = rRange.PivotTable
    If Not pPivotTable Is Nothing Then getCURRENT_PIVOTTABLE_NAME = pPivotTable.Name
End Function

3. Récupérer le nombre d'enregistrements de la source

VB:

Function getPIVOTTABLE_RECORDS_COUNT(Optional hTCD As String = "CurrentTCD", Optional hWK As String = "ActiveSheet") As Variant
'******************************************************************
' On récupère le nombre d'enregistrements de la source de données
'******************************************************************
    Dim wk As Worksheet
    Dim rRange As Range
    Dim pPivotTable As PivotTable
    Dim pPivotCaches As PivotCaches
    Dim pPivotCache As PivotCache
 
    Set rRange = ActiveCell
    getPIVOTTABLE_RECORDS_COUNT = CVErr(xlErrNA)
 
    '***********************************************************************
    '* On force le passage
    '***********************************************************************
    On Error Resume Next
 
    If hTCD = "CurrentTCD" Then
        Set pPivotTable = rRange.PivotTable
    Else
        If hWK = "ActiveSheet" Then
            Set wk = ActiveSheet
        Else
            '***************************
            '* L'onglet existe?
            '***************************
            If Not existsWK(hWK) Then
                Exit Function
            End If
            Set wk = ActiveWorkbook.Worksheets(hWK)
        End If
        '********************************
        ' Le TCD existe ?
        '********************************
        If existsPivotTable(hTCD) Then
            Set pPivotTable = wk.PivotTables(hTCD)
        Else
            Exit Function
        End If
    End If
 
    '**********************************************************************
    ' Par sécurité on vérifie si PivotTable est bien assigné
    '**********************************************************************
    If pPivotTable Is Nothing Then
        Exit Function
    End If
 
    Set pPivotCaches = ActiveWorkbook.PivotCaches
 
    Set pPivotCache = pPivotCaches(pPivotTable.CacheIndex)
    getPIVOTTABLE_RECORDS_COUNT = CLng(pPivotCache.RecordCount)
 
End Function

4. Nom de la source de données

VB:

Function getPIVOTTABLE_SOURCE_DATA(Optional hTCD As String = "CurrentTCD", Optional hWK As String = "ActiveSheet") As Variant
'******************************************************************
' On récupère le nom de la source de données
'******************************************************************
    Dim wk As Worksheet
    Dim rRange As Range
    Dim pPivotTable As PivotTable
    Dim pPivotCaches As PivotCaches
    Dim pPivotCache As PivotCache

 
    Set rRange = ActiveCell
    getPIVOTTABLE_SOURCE_DATA = CVErr(xlErrNA)
 
    '***********************************************************************
    '* On force le passage
    '***********************************************************************
    On Error Resume Next
 
    If hTCD = "CurrentTCD" Then
        Set pPivotTable = rRange.PivotTable
    Else
        If hWK = "ActiveSheet" Then
            Set wk = ActiveSheet
        Else
            '***************************
            '* L'onglet existe?
            '***************************
            If Not existsWK(hWK) Then
                Exit Function
            End If
            Set wk = ActiveWorkbook.Worksheets(hWK)
        End If
        '********************************
        ' Le TCD existe ?
        '********************************
        If existsPivotTable(hTCD) Then
            Set pPivotTable = wk.PivotTables(hTCD)
        Else
            Exit Function
        End If
    End If
 
    '**********************************************************************
    ' Par sécurité on vérifie si PivotTable est bien assigné
    '**********************************************************************
    If pPivotTable Is Nothing Then
        Exit Function
    End If
 
    Set pPivotCaches = ActiveWorkbook.PivotCaches
 
    Set pPivotCache = pPivotCaches(pPivotTable.CacheIndex)
    getPIVOTTABLE_SOURCE_DATA = pPivotTable.SourceData
 
End Function

5. Quelle est son occupation en mémoire ?

VB:

Function getPIVOTTABLE_MEMORY(Optional hTCD As String = "CurrentTCD", Optional hWK As String = "ActiveSheet") As Variant
'******************************************************************
' On récupère la valeur occupée en mémoire
'******************************************************************
    Dim wk As Worksheet
    Dim rRange As Range
    Dim pPivotTable As PivotTable
    Dim pPivotCaches As PivotCaches
    Dim pPivotCache As PivotCache

 
    Set rRange = ActiveCell
    getPIVOTTABLE_MEMORY = CVErr(xlErrNA)
 
    '***********************************************************************
    '* On force le passage
    '***********************************************************************
    On Error Resume Next
 
    If hTCD = "CurrentTCD" Then
        Set pPivotTable = rRange.PivotTable
    Else
        If hWK = "ActiveSheet" Then
            Set wk = ActiveSheet
        Else
            '***************************
            '* L'onglet existe?
            '***************************
            If Not existsWK(hWK) Then
                Exit Function
            End If
            Set wk = ActiveWorkbook.Worksheets(hWK)
        End If
        '********************************
        ' Le TCD existe ?
        '********************************
        If existsPivotTable(hTCD) Then
            Set pPivotTable = wk.PivotTables(hTCD)
        Else
            Exit Function
        End If
    End If
 
    '**********************************************************************
    ' Par sécurité on vérifie si PivotTable est bien assigné
    '**********************************************************************
    If pPivotTable Is Nothing Then
        Exit Function
    End If
 
    Set pPivotCaches = ActiveWorkbook.PivotCaches
 
    Set pPivotCache = pPivotCaches(pPivotTable.CacheIndex)
    getPIVOTTABLE_MEMORY = pPivotCache.MemoryUsed
 
End Function

6. Purger tous les caches des TCD

VB:

Sub PURGER_TOUS_LES_PIVOTS_CACHES()
'******************************************************************
' On va purger tous les caches des TCD
'******************************************************************
    Dim pPivotTable As PivotTable
    Dim wks As Worksheet
    Dim pPivotCache As PivotCache
 
    On Error GoTo HANDLE_ERROR
 
    Set oSpeed = New SpeedMacro
 
    oSpeed.SpeedMacroOn

    '*************************************
    ' Nombre d'éléments à retenir : Aucun
    '*************************************
    For Each wks In ActiveWorkbook.Worksheets
        For Each pPivotTable In wks.PivotTables
            pPivotTable.PivotCache.MissingItemsLimit = xlMissingItemsNone
        Next
    Next
 
    '*************************************
    ' Et on actualise tous les caches
    '*************************************
    For Each pPivotCache In ActiveWorkbook.PivotCaches
        pPivotCache.Refresh
    Next
     
FIN:
    oSpeed.SpeedMacroOff
    Exit Sub
 
HANDLE_ERROR:
    MsgBox "Purge du cache des TCD impossible. Erreur #" & Err.Number & " - " & Err.Description, vbCritical, "Purge Cache"
    Resume FIN
End Sub

7. par une fonction

VB:

Function isPURGER_TOUS_LES_PIVOTS_CACHES() As Boolean
'******************************************************************
' On va purge tous les caches des TCD - la même mais en fonction
'******************************************************************
    Dim pPivotTable As PivotTable
    Dim wks As Worksheet
    Dim pPivotCache As PivotCache
 
    On Error GoTo HANDLE_ERROR
 
    isPURGER_TOUS_LES_PIVOTS_CACHES = False
 
    Set oSpeed = New SpeedMacro
 
    oSpeed.SpeedMacroOn

    '*************************************
    ' Nombre d'éléments à retenir : Aucun
    '*************************************
    For Each wks In ActiveWorkbook.Worksheets
        For Each pPivotTable In wks.PivotTables
            pPivotTable.PivotCache.MissingItemsLimit = xlMissingItemsNone
        Next
    Next
 
    '*************************************
    ' Et on actualise tous les caches
    '*************************************
    For Each pPivotCache In ActiveWorkbook.PivotCaches
        pPivotCache.Refresh
    Next
 
    isPURGER_TOUS_LES_PIVOTS_CACHES = True
     
FIN:
    oSpeed.SpeedMacroOff
    Exit Function
 
HANDLE_ERROR:
    isPURGER_TOUS_LES_PIVOTS_CACHES = False
    Resume FIN
End Function

8. Sur une feuille précise

VB:

Function isPURGER_PIVOT_CACHE_FEUILLE(Optional hWK As String = "ActiveSheet") As Boolean
'******************************************************************
' On va purger les caches d'une feuille
'******************************************************************
    Dim wk As Worksheet
    Dim pPivotTable As PivotTable
    Dim pPivotCaches As PivotCaches
    Dim pPivotCache As PivotCache
 
    isPURGER_PIVOT_CACHE_FEUILLE = False
 
    Set oSpeed = New SpeedMacro
 
    oSpeed.SpeedMacroOn
 
    If hWK = "ActiveSheet" Then
        Set wk = ActiveSheet
    Else
            '***************************
            '* L'onglet existe?
            '***************************
            If Not existsWK(hWK) Then
                Exit Function
            End If
            Set wk = ActiveWorkbook.Worksheets(hWK)
    End If
 
    '**********************************************************************
    ' Purge des caches propres à la feuille et rafraîchir les TCD
    '**********************************************************************
    For Each pPivotTable In wk.PivotTables
        pPivotTable.PivotCache.MissingItemsLimit = xlMissingItemsNone
        Call pPivotTable.PivotCache.Refresh
    Next
     
    isPURGER_PIVOT_CACHE_FEUILLE = True
 
End Function

9. Sur une feuille et un TCD donnée

VB:

Function isPURGER_UN_PIVOTTABLE(hTCD As String, Optional hWK As String = "ActiveSheet") As Boolean
'******************************************************************
' On va purger le cache d'une feuille
'******************************************************************
    Dim wk As Worksheet
    Dim rRange As Range
    Dim pPivotTable As PivotTable
    Dim pPivotCaches As PivotCaches
    Dim pPivotCache As PivotCache

 
    Set rRange = ActiveCell
    isPURGER_UN_PIVOTTABLE = False
 
    '***********************************************************************
    '* On force le passage
    '***********************************************************************
    On Error Resume Next
 
    If hWK = "ActiveSheet" Then
        Set wk = ActiveSheet
    Else
        '***************************
        '* L'onglet existe?
        '***************************
        If Not existsWK(hWK) Then
            Exit Function
        End If
        Set wk = ActiveWorkbook.Worksheets(hWK)
    End If
 
    '********************************
    ' Le TCD existe ?
    '********************************
    If existsPivotTable(hTCD) Then
        Set pPivotTable = wk.PivotTables(hTCD)
    Else
        Exit Function
    End If
 
    '**********************************************************************
    ' Par sécurité on vérifie si PivotTable est bien assigné
    '**********************************************************************
    If pPivotTable Is Nothing Then
        Exit Function
    End If
 
    Set pPivotCaches = ActiveWorkbook.PivotCaches
    Set pPivotCache = pPivotCaches(pPivotTable.CacheIndex)
    pPivotTable.PivotCache.MissingItemsLimit = xlMissingItemsNone
    Call pPivotTable.PivotCache.Refresh
 
    isPURGER_UN_PIVOTTABLE = True
 
End Function

10. La feuille active

VB:

Function isPURGER_ACTIVE_PIVOTTABLE() As Boolean
'******************************************************************
' On va purger tous les caches de la feuille active
'******************************************************************
    Dim wk As Worksheet
    Dim rRange As Range
    Dim pPivotTable As PivotTable
    Dim pPivotCaches As PivotCaches
    Dim pPivotCache As PivotCache
 
    Set rRange = ActiveCell
    Set wk = ActiveSheet
 
    isPURGER_ACTIVE_PIVOTTABLE = False
 
    '***********************************************************************
    '* On force le passage
    '***********************************************************************
    On Error Resume Next

    Set pPivotTable = rRange.PivotTable
 
    '**********************************************************************
    ' On vérifie si on se trouve sur un TCD
    '**********************************************************************
    If pPivotTable Is Nothing Then
        Exit Function
    End If
 
    Set pPivotCaches = ActiveWorkbook.PivotCaches
    Set pPivotCache = pPivotCaches(pPivotTable.CacheIndex)
    pPivotTable.PivotCache.MissingItemsLimit = xlMissingItemsNone
    Call pPivotTable.PivotCache.Refresh
 
    isPURGER_ACTIVE_PIVOTTABLE = True
 
End Function

11. Connaître le nombre de cache

VB:

Function getCOUNT_PIVOT_CACHES() As Integer
'******************************************************************
' On va récupérer le Nbr de caches dans le classeur
'******************************************************************

      getCOUNT_PIVOT_CACHES = ActiveWorkbook.PivotCaches.Count
   
End Function

12. Affecter un cache commun à tous les TCD

VB:

Function isAFFECTER_CACHE_INDEX(hTCD As String, hWK As String) As Boolean
'******************************************************************
' On va affecter le même cache à tous les TCD du classeur
'******************************************************************
    Dim pPivotTable As PivotTable
    Dim wks As Worksheet
 
    On Error GoTo HANDLE_ERROR
 
    isAFFECTER_CACHE_INDEX = False
 
    If Not existsWK(hWK) Then
        Exit Function
    End If
 
    If Not existsPivotTable(hTCD) Then
        Exit Function
    End If
 
    For Each wks In ActiveWorkbook.Worksheets
        For Each pPivotTable In wks.PivotTables
            pPivotTable.CacheIndex = ActiveWorkbook.Worksheets(hWK).PivotTables(hTCD).CacheIndex
        Next
    Next
 
    isAFFECTER_CACHE_INDEX = True
 
FIN:
    Exit Function

HANDLE_ERROR:
    isAFFECTER_CACHE_INDEX = False
    Resume FIN

End Function

Liste de tests divers

VB:

Sub TEST_isPIVOT_TABLE_1()
    MsgBox isCURRENT_PIVOT_TABLE()
End Sub

Sub TEST_isPIVOT_TABLE_2()
    MsgBox isCURRENT_PIVOT_TABLE(Range("B7"))
End Sub

Sub TEST_getCURRENT_PIVOTTABLE_NAME_1()
    MsgBox getCURRENT_PIVOTTABLE_NAME
End Sub

Sub TEST_getCURRENT_PIVOTTABLE_NAME_2()
    MsgBox getCURRENT_PIVOTTABLE_NAME(Range("B7"))
End Sub

Sub TEST_getPIVOTTABLE_RECORDS_COUNT_1()
    MsgBox getPIVOTTABLE_RECORDS_COUNT()
End Sub

Sub TEST_getPIVOTTABLE_RECORDS_COUNT_2()
    MsgBox getPIVOTTABLE_RECORDS_COUNT("TCD_2", "CLEAR_PIVOT_CACHE")
End Sub

Sub TEST_getPIVOTTABLE_SOURCE_DATA_1()
    MsgBox getPIVOTTABLE_SOURCE_DATA()
End Sub

Sub TEST_getgetPIVOTTABLE_SOURCE_DATA_2()
    MsgBox getPIVOTTABLE_SOURCE_DATA("TCD_2", "CLEAR_PIVOT_CACHE")
End Sub

Sub TEST_getPIVOTTABLE_MEMORY_1()
    MsgBox getPIVOTTABLE_MEMORY()
End Sub

Sub TEST_getgetPIVOTTABLE_MEMORY_2()
    MsgBox getPIVOTTABLE_MEMORY("TCD_2", "CLEAR_PIVOT_CACHE")
End Sub

Sub TEST_PURGER_TOUS_LES_PIVOTS_CACHES_1()
    Call PURGER_TOUS_LES_PIVOTS_CACHES
End Sub

Sub TEST_isPURGER_TOUS_LES_PIVOTS_CACHES_1()
    MsgBox isPURGER_TOUS_LES_PIVOTS_CACHES()
End Sub

Sub TEST_isPURGER_PIVOT_CACHE_FEUILLE_1()
    MsgBox isPURGER_PIVOT_CACHE_FEUILLE()
End Sub

Sub TEST_isPURGER_PIVOT_CACHE_FEUILLE_2()
    MsgBox isPURGER_PIVOT_CACHE_FEUILLE("CLEAR_PIVOT_CACHE")
End Sub

Sub TEST_isPURGER_ACTIVE_PIVOTTABLE_1()
    MsgBox isPURGER_ACTIVE_PIVOTTABLE()
End Sub

Sub TEST_isPURGER_UN_PIVOTTABLE_1()
    MsgBox isPURGER_UN_PIVOTTABLE("TCD_2")
End Sub

Sub TEST_isPURGER_UN_PIVOTTABLE_2()
    MsgBox isPURGER_UN_PIVOTTABLE("TCD_1", "STOCKS_ALIMENTS")
End Sub

Sub TEST_getCOUNT_PIVOT_CACHES_1()
    MsgBox getCOUNT_PIVOT_CACHES()
End Sub

Sub TEST_01()
    ActiveSheet.PivotTables("TCD_2").PivotCache.MissingItemsLimit = xlMissingItemsNone
End Sub

Sub TEST_isAFFECTER_CACHE_INDEX_1()
    MsgBox isAFFECTER_CACHE_INDEX("TCD_2", "CLEAR_PIVOT_CACHE")
End Sub

Sub TEST_isAFFECTER_CACHE_INDEX_2()
    MsgBox isAFFECTER_CACHE_INDEX("TCD_1", "STOCKS_ALIMENTS")
End Sub

Sub TESTS_DIVERS_1()
    Dim rRange As Range
    Dim pPivotTable As PivotTable
    Dim pPivotCaches As PivotCaches
    Dim pPivotCache As PivotCache
    Set rRange = ActiveCell
    On Error Resume Next
    Set pPivotTable = rRange.PivotTable
    Set pPivotCaches = ActiveWorkbook.PivotCaches
    Set pPivotCache = pPivotCaches(pPivotTable.CacheIndex)
    Debug.Print "pPivotTable.Name=" & pPivotTable.Name
    Debug.Print "pPivotTable.CacheIndex=" & pPivotTable.CacheIndex
    Debug.Print "pPivotCaches(pPivotTable.CacheIndex).RecordCount=" & pPivotCaches(pPivotTable.CacheIndex).RecordCount
    Debug.Print "pPivotCache.RecordCount=" & pPivotCache.RecordCount
    Debug.Print "pPivotCache.MemoryUsed=" & pPivotCache.MemoryUsed
    Debug.Print Err.Number
End Sub

Effectuez une recherche sur Excel Downloads...

EXCEL :: VBA :: PIVOTTABLE :: PIVOTCACHE :: Nettoyer le cache des TCD

oguruma

XLDnaute Occasionnel

Pièces jointes

Discussions similaires

Nous accordons de l'importance à votre vie privée