Bonjour à tous,
voici une macro de mon cru permettant de gérer une barre de progression pendant un traitement.

C'est avant tout du bricolage, mais ça à le mérite de marcher:
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
Function Cree_Barre_Progression(Nom_Feuille As String) As Variant
'Cette procédure crée une barre de progression dans la feuille en paramètres,
' et renvoie les noms des trois shapes
' Nom_Feuille est la feuille où on veut afficher la barre
 
Dim cadre As Shape
Dim barre_vide As Shape
Dim barre_pleine As Shape
 
Dim liste_noms(3) As String
 
Set cadre = ThisWorkbook.Sheets(Nom_Feuille).Shapes.AddShape(msoShapeRectangle, 150, 150, 640, 200)
cadre.Name = "Cadre barre progression"
cadre.Select
Selection.Characters.Text = "Veuillez patienter, Excel effectue un traitement..."
 
With Selection.Characters.Font
     .Name = "Arial"
     .Bold = True
     .Size = 14
End With
Selection.HorizontalAlignment = xlCenter
 
Set barre_vide = ThisWorkbook.Sheets(Nom_Feuille).Shapes.AddShape(msoShapeRectangle, 220, 180, 500, 60)
barre_vide.Name = "Barre vide"
 
Set barre_pleine = ThisWorkbook.Sheets(Nom_Feuille).Shapes.AddShape(msoShapeRectangle, 220, 180, 1, 60)
barre_pleine.Name = "Barre pleine"
barre_pleine.Fill.ForeColor.SchemeColor = 17
 
'Pour actualiser l'écran, à améliorer...
Application.SendKeys "F5"
 
Cree_Barre_Progression = Array(cadre.Name, barre_vide.Name, barre_pleine.Name)
 
End Function
 
Sub Suppr_Barre_Progression(Nom_Feuille As String, Liste_Barre As Variant)
'Cette procédure supprime la barre de progression dans la feuille en paramètres,
' et renvoie un booléen
' Nom_Feuille est la feuille où on veut afficher la barre
' Liste_Barre est un tableau avec les noms des Shapes composant la barre
 
'---Erreur ignorée systématiquement
'---Procédure à intégrer dans du code sans ErrorHandler
On Error Resume Next
'On supprime tous les shapes dont le nom fait partie des paramètres
ThisWorkbook.Sheets(Nom_Feuille).Shapes(Liste_Barre(0)).Delete
ThisWorkbook.Sheets(Nom_Feuille).Shapes(Liste_Barre(1)).Delete
ThisWorkbook.Sheets(Nom_Feuille).Shapes(Liste_Barre(2)).Delete
 
On Error GoTo 0
 
End Sub
 
Sub MaJ_Barre_Progression(Nom_Feuille As String, Liste_Barre As Variant, Avancement As Integer)
'Cette procédure agrandit la barre de progression dans la feuille en paramètres,  et renvoie un booléen
' Nom_Feuille est la feuille où on veut afficher la barre
' Liste_Barre est un tableau avec les noms des Shapes composant la barre
' Avancement est le pourcentage
 
Dim taille_barre_vide As Integer
Dim taille_barre_pleine As Integer
 
taille_barre_vide = ThisWorkbook.Sheets(Nom_Feuille).Shapes(Liste_Barre(1)).Width
taille_barre_pleine = Int(Avancement / 100 * taille_barre_vide)
 
ThisWorkbook.Sheets(Nom_Feuille).Shapes(Liste_Barre(2)).Width = taille_barre_pleine
 
'Pour actualiser l'écran, à améliorer...
Application.SendKeys "F5"
 
End Sub
Dans l'utilisation, je mets Cree_Barre_Progression avant ma boucle, Suppr_Barre_Progression après, et MaJ_Barre_Progression dans la boucle, juste avant l'incrémentation de mon parcours.

Remarque: Pour pouvoir utiliser ce code, il faut pouvoir évaluer l'avancement... Par exemple, je fais:
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
nb_enreg = rs.RecordCount
num_lig = 1
avant la boucle, puis ensuite:
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
num_lig = num_lig + 1
progression = Int(num_lig / nb_enreg * 100)
Call MaJ_Barre_Progression("Données", barre_progression, progression)
Liste_Article.MoveNext
Ce code peut être optimisé, aussi je vous invite à commenter... Surtout pour le SendKeys que j'aimerais remplacer par autre chose...