Bonjour,

Je souhaiterai savoir comment mettre en place une barre d'avancement.
En effet, ma macro "echange" est trés longue à s'exécuter et je désire mettre une barre qui montre l'avancement de la macro afin de savoir où en est son execution.

Je dois avouer que je ne sais vraiment pas comment m'y prendre pour creer cette barre d'avancement.

Je suis en VBA et la macro contient 3 boucles
L'excecution de la macro se fait par l'intermédiare d'un "useform" intitulé également echange".

je vous joins la macro et merci d'avance de votre aide.

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
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
Sub echange()
 
   'Les variables
    Dim d As Long ' c correspond a la derniere ligne de la colonne "code liaison" du tableau hermes
    Dim Quai As String
    Dim a As Long 'a coorespond à la dernière ligne de la colonne A du tableau "echange 2010"
 
 
 
 
                                    'SUR LE FICHIER HERMES DEPART ou ARRIVEE
 
 
 
    Quai = Cells(1, 3).Value ' cellule de la premiere ligne, seconde colonne soit C1
    d = Range("d" & Range("d65536").End(xlUp).Row).Row ' formule pour recuperer le N° de la dernière ligne de la colonne "code liaison"
 
    Application.ScreenUpdating = False 'la mise à jour de l'écran est désactivée
 
    Cells.Select 'selectionner tout le tableau
    On Error Resume Next 'gestion des erreurs qui permet de continuer le programme
    'meme s'il y a une erreur : dans ce ca precis les les filtres peuvent etre tous affiches
    ActiveSheet.ShowAllData ' afficher tous les filtres
    On Error GoTo 0 ' interruption de la gestion des erreurs
 
    Range("A6:AC" & d - 1).Select ' selection du tableau allant de la cellule A6 a la derniere cellule de la colonne AC "surcapacite"
    Selection.Copy
 
 
 
    'SELECTIONNER / OUVRIR LE FICHIER "ECHANGE 2010"
    On Error GoTo GestionErreurFichier
    Workbooks("echanges slm 2011.xls").Worksheets("donnees hermes").Activate
    On Error GoTo 0
 
 
 
                                    'SUR LE FICHIER "ECHANGE 2010"
 
 
 
Cells.Select 'selectionner le tableau echange
On Error Resume Next 'gestion des erreurs qui permet de continuer le programme
'meme s'il y a une erreur : dans ce ca precis les les filtres peuvent etre tous affiches
ActiveSheet.ShowAllData ' afficher tous les filtres
On Error GoTo 0 ' interruption de la gestion des erreurs
 
  'Insertion du fichier hermes dans le tableau echange
Range("C2").Select
If Range("C3").Value <> "" Then Range("C2").End(xlDown).Select
'Si la cellule C3 n'est pas vide, on selectionne la derniere cellule non vide de la colonne C.
'Si C3 est libre, la derniere cellule non vide est C2. Il n'est pas necesaire de se deplacer.
ActiveCell.Offset(1, 0).Select
'On selectionne la cellule situee une ligne en dessous de la cellule active.
'Enfait, on se positionne sur la premiere ligne vide de la feuille "echange 2010".
 
 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'on copie le tableau selectionner a partir de la premiere ligne  vide de la feuille "echange 2010
Application.CutCopyMode = False 'instrcution qui permet d'effacer la marque de selection autor de la plage copiee
 
 
 
 
    ' INSERTION DU MOIS dans la colonne B et du QUAI DANS LA COLONNE A
    Range("B2").Select
    If Range("B3").Value <> "" Then Range("B2").End(xlDown).Select 'Si la cellule B3 n'est pas vide,
    'on selectionne la derniere cellule non vide de la colonne B. Si B3 est libre, la derniere cellule non vide est B2.
    'Il n'est pas necesaire de se deplacer.
    ActiveCell.Offset(1, 1).Select 'On selectionne la cellule situee une ligne en dessous de la cellule active et a droite.
'Enfait, on se positionne sur la premiere cellule non vide de la colonne C (colonne date) situe a droite de la premiere cellule vide de la colonne B (colonne MOIS) .
 
    LigDeb = ActiveCell.Row 'ligne active qui correspond a la 1er ligne vide de la colonne B ( colonne MOIS)
    LigFin = Range("C2").End(xlDown).Row 'derniere cellule non vide de la colonne C (colonne MOIS)
 
    On Error Resume Next 'gestion des erreurs qui permet de continuer le programme
    'meme s'il y a une erreur : dans ce ca precis les les filtres peuvent etre tous affiches
    On Error GoTo 0 ' interruption de la gestion des erreurs
 
 
   For Each Cell In Range("C" & LigDeb & ":C" & LigFin) ' pour chaque cellule du tableau allant de LigDeb (=de la 1er cellule vide situé à droite de la 1er cellule vide de la colonne B (date)) jusqu'à Ligfin(=la derniere cellule non vide de la colonne B (date))
   Cell.Offset(o, -1) = Format(CDate(Cell), "mmmm")
   Cell.Offset(0, -2).Value = Quai
   Next
 
 a = Range("a" & Range("a65536").End(xlUp).Row).Row 'adaptation de la formule pour recuperer le N° de la dernière cellule de la colonne A
 
 
Range("AD3").Select 'colonne "CP TOTAL"
ActiveCell.FormulaR1C1 = "=RC[-16]+RC[-14]+RC[-8]+RC[-6]"
'RC[-6]= CPR
'RC[- 8]= CPHN
'RC[-14]= CP VIDES
'RC[-16]= CP PLEINS
 
Range("AD3").Copy
Range("AD3:AD" & a).Select 'selection de la zone de copie allant de la cellule Z3 à la dernier ligne non vide de la colonne Z
Selection.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
 
Range("AG3").Select ' colonne "SURCAPACITE"
ActiveCell.FormulaR1C1 = "=IF(AND(RC[-28]<>""nyk"",RIGHT(RC[-27],2)<>""dp""),IF(RC[-3]>33,""surcapacite"",""""),"""")"
'RC[-28]=ligne
'RC[-27]=code liaison
'RC[-3]=CP total
 
Range("AG3").Copy
Range("AG3:AG" & a).Select 'selection de la zone de copie
Selection.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
 
 
 
 
'Copie de la formule "traduction" sur toutes les cellules de la colonne AE(DEPARTEMENT)
Range("AE3").Copy
Range("AE3:AE" & a).Select 'selection de la zone de copie allant de la cellule AE3 à la dernier ligne non vide de la colonne X
Selection.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
'Colonne AF " journee postale"
Range("AF3").Copy 'Copier la formule contenue dans la cellule AF3
Range("AF3:AF" & a).Select ' selection de la colonne allant de AF3 à la derniere ligne non vide de la colonne AG
Selection.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' copier
 
 
Application.ScreenUpdating = True 'la mise à jour de l'écran est activée
 
    ' CREATION DES SOUS TOTAUX
' Mise en  place d'une boucle do..loop ; celle -ci commence a partir de la cellule x (ligne 3 colonne 3) et s'arrete a la premiere cellule vide rencontree dans la colonne 3
    Lig = 3
    Do
       X = Cells(Lig, 3).Value
        If X = "" Then Exit Do ' si la cellule est vide alors je quitte la boucle
        Lig = Lig + 1 ' si la cellule est NON vide alors on aditionne a la ligne 3 la ligne de dessous
    Loop
    LigFin = Lig - 1 ' sortie de la boucle . Lig -2 =Numero de la derniere ligne non vide
    LigDeb = 2
    Cells(1, 1).Select
 
    Range("N1").Select '  N1= CP 660
    ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[" & LigDeb & "]C:R[" & LigFin - 1 & "]C)"
    Range("N1").Select
    Selection.Copy
    Range("N1:X1,AB1,AD1").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
    Application.CutCopyMode = False 'instrcution qui permet d'effacer la marque de selection autor de la plage copiee
 
 
 
Application.ScreenUpdating = False 'désactive la mise à jour de l'écran
 
 
        ' CREATION DES SOUS TOTAUX
 
' Mise en place d'une boucle do..loop ; celle -ci commence a partir de la cellule x (ligne 6 colonne 4) et s'arrete a la premiere cellule vide rencontree dans la colonne 4
    Lig = 3
    Do
       X = Cells(Lig, 5).Value ' le chiffre 5 correspond à la 5 ième colonne cad colonne "ligne".
        If X = "" Then Exit Do ' si la cellule est vide alors je quitte la boucle
        Lig = Lig + 1 ' si la cellule est NON vide alors on aditionne a la ligne 3 la ligne de dessous
    Loop
    LigFin = Lig - 1 ' sortie de la boucle . Lig -1 =Numero de la derniere ligne non vide ; le chiffre 1 correspond à la première lignes du tableau(ligne de Nom)
    LigDeb = 2
    Cells(1, 1).Select
 
 
 
 
    'Creation de la formule sous.total (avec l'argument 3)
   Range("E1").Select
   ActiveCell.FormulaR1C1 = "=SUBTOTAL(3,R[" & LigDeb & "]C:R[" & LigFin - 1 & "]C)"
 
  'Mise en forme de la cellule D1
  Range("E1").Select
  Selection.Font.ColorIndex = 55 ' couleur
  Selection.Font.Bold = True ' gras
  Selection.NumberFormat = "#,##0" 'format nombre sans virgule avec séparateur de millier
 
'copier la cellule D1 sur la cellule AD1
'Range("D1").Select
'Selection.Copy
'Range("AD1").Select
'Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
 
Application.ScreenUpdating = True 'rétablit la mise à jour de l'écran
 
Range("A1").CurrentRegion.Rows(Range("A1").CurrentRegion.Rows.Count).Select
ActiveWorkbook.Save
 
Exit Sub
 
GestionErreurFichier:
   Workbooks.Open Filename:="P:\Commun\Transport Securité\Docs Madjid\echanges slm 2011.xls"
 
    Resume
 
End Sub