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

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