XL 2016 Comment intégrer une progressbar pour montrer l'évolution de la synchro des TCDS

[scoubidou35]

Bonjour à tous,
On est encore en janvier, je vous souhaite donc une bonne et heureuse année 2021 en espérant que 2020 ne soit qu'un mauvais souvenir.

J'utilise le code suivant pour synchroniser plusieurs TCD en même temps à l'aide des segments.
Mais comme le fichier est volumineux, il se passe du temps et des collègues ont cru à un bug et m'ont à plusieurs reprises appeler pour me signaler un problème qui n'existe pas.
Je pensais donc à intégrer une progressbar qui s'afficherait lors de la synchronisation pour montrer l'évolution.
Mais je n'y arrive pas. Peut être que ce n'ai pas possible avec les TCD. Si quelqu'un sait comment faire je suis tout ouïe.

Option Base 1

Private Sub Workbook_SheetPivotTableUpdate(ByVal Sh As Object, ByVal Target As PivotTable)
Dim Ninsert&, espace&, a(), i&, col%, j&, z&
Ninsert = 500 'à adapter
Application.ScreenUpdating = False
ReDim a(1 To Sh.PivotTables.Count, 3)

'Condition ou Liste des onglets non concernés
If UBound(a, 1) = 1 Then Exit Sub 'il y a seulement un TCD dans la feuille
If Sh.Name = "ACHATS" Then Exit Sub

'Synchro segments
On Error Resume Next
If Sh.Name = "FICHES I.T.K" Then Call Synchro_Segments(ActiveSheet.CodeName, Target)
 
'Espacement TCD
With Sh
.Cells.EntireRow.Hidden = False
For i = 1 To UBound(a, 1)
a(i, 1) = .PivotTables(i).TableRange2.Row
a(i, 2) = .PivotTables(i).TableRange2.Rows.Count
Next
 
Call tri(a(), 1, UBound(a, 1), 2, 1)
 
'Insertion ou suppression de lignes---
For i = 1 To UBound(a, 1) - 1
espace = a(i + 1, 1) - (a(i, 1) + a(i, 2))
If espace < Ninsert Then a(i, 3) = Ninsert - espace Else a(i, 3) = Ninsert - espace
 
Next
 
For i = UBound(a, 1) To 2 Step -1
z = a(i - 1, 3)
If z > 0 Then
.Rows(a(i - 1, 1) + a(i - 1, 2)).Resize(z).Insert
ElseIf z < 0 Then
z = -z
.Rows(a(i - 1, 1) + a(i - 1, 2)).Resize(z).EntireRow.Delete
End If

'Masquage
.Rows(a(i - 1, 1) + a(i - 1, 2) & ":" & a(i, 1) + a(i - 1, 3) - 4).EntireRow.Hidden = True
Next
End With
End Sub

Sub test()
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

' TRI D'UN ARRAY 2D via la colonne N°colTri
' a() = le tableau à trier
' gauc = indice bas du tableau
' droi = indice haut du tableau
' colTri = la colonne sur laquelle on effectue le tri
' http://boisgontierjacques.free.fr/

Sub tri(a(), gauc, droi, NbCol, colTri)        ' Quick sort (JBGontier)
ref = a((gauc + droi) \ 2, colTri)
g = gauc: D = droi
Do
Do While a(g, colTri) < ref: g = g + 1: Loop
Do While ref < a(D, colTri): D = D - 1: Loop
If g <= D Then
For C = 1 To NbCol
temp = a(g, C): a(g, C) = a(D, C): a(D, C) = temp
Next
 
g = g + 1: D = D - 1
End If
Loop While g <= D
 
If g < droi Then Call tri(a, g, droi, NbCol, colTri)
    If gauc < D Then Call tri(a, gauc, D, NbCol, colTri)
End Sub

Sub Synchro_Segments(Feuille, TCD)

'Synchro des segments de la feuille
Dim SegmentF 'Table des segments liés au TCD + segments de même nom
Dim y As Integer 'Dimension de la table
Dim Seg As SlicerCache, Seg2 As SlicerCache 'Segments analysés
Dim K As Integer '1er segment de la série
Dim X As Integer 'Nombre de segments du classeur
Dim Trouve As Boolean 'permet de savoir si la comparaison est OK ou pas

X = ActiveWorkbook.SlicerCaches.Count

ReDim SegmentF(X)

'Table des segments liés au TCD filtré
'Les segments sont supposés avec le même nom suivi de _ puis un numéro différent pour un même champ
'Le premier de la série est celui lié au TCD qui déclenche le code

For i = 1 To X
Set Seg = ActiveWorkbook.SlicerCaches(i)
For Each PTlien In Seg.PivotTables
If PTlien = TCD Then
y = y + 1: SegmentF(y) = Seg.Name
For j = 1 To X
Set Seg2 = ActiveWorkbook.SlicerCaches(j)
For Each Ptlien2 In Seg2.PivotTables
Trouve = False
If Ptlien2.Parent.CodeName = Feuille Then
If Seg.Name <> Seg2.Name And SegRacine(Seg2.Name) = SegRacine(Seg.Name) Then y = y + 1: SegmentF(y) = Seg2.Name: Trouve = True: Exit For
End If
Next Ptlien2
Next j
End If
Next PTlien
Next i

ReDim Preserve SegmentF(y)

'Filtre
'On Error GoTo FIN
On Error Resume Next
Application.EnableEvents = False
K = 1
For i = 1 To UBound(SegmentF) - 1
If SegRacine(SegmentF(K)) = SegRacine(SegmentF(i + 1)) Then
ActiveWorkbook.SlicerCaches(SegmentF(i + 1)).ClearManualFilter
For Each Iitem In ActiveWorkbook.SlicerCaches(SegmentF(i + 1)).SlicerItems
For Each Iitem2 In ActiveWorkbook.SlicerCaches(SegmentF(K)).SlicerItems
If Iitem.Name = Iitem2.Name Then ActiveWorkbook.SlicerCaches(SegmentF(i + 1)).SlicerItems(Iitem.Name).Selected = Iitem2.Selected: Exit For
Next Iitem2
Next Iitem
Else
K = i + 1
End If
Next
'FIN:
Application.EnableEvents = True

End Sub

Function SegRacine(Segment)
Nom = Mid(Segment, InStr(Segment, "_") + 1, 100)
Do While Asc(Right(Nom, 1)) >= Asc("0") And Asc(Right(Nom, 1)) <= Asc("9")
Nom = Left(Nom, Len(Nom) - 1)
Loop
SegRacine = Nom
End Function

 

[scoubidou35]

Je suis toujours avec mon problème mais je réussi à faire apparaitre la progressbar mais pas sur que ce soit au bon moment (j'ai l'impression qu'elle apparait tout de suite après le premier filtre et je ne sais pas si c'est la meilleur méthode) puis plus rien après.