Discussion :

[facteur]

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

[mercatog]

Bonjour

Désolé de te faire la remarque, mais ton code est démesurément non optimisé
avec l'utilisation systématique de Select, Activate, Selection, Activecell, Range sans adressage complet, utilisation non justifiée de boucles et de copier/ pastespecial.
C'est là que tu perds ton temps.

[facteur]

Bonjour mercatog,
Effectivement cette macro a ete cree au fil de l'eau sans que j'essaie de l'optimiser et ja'i une fleme de la reprendre afin de la simplifier .
Et pour ce qui de la barre de defilement, pourrais tu m'aider ou dois je reprendre la macro pour y apporter les modifications pour nla rendre plus optimal

[mercatog]

Bonjour
Tu devrais reprendre la macro (c'est mon avis) en évitant les remarques précédentes.

[facteur]

Bonjour mercatog,
Je vais devoir donc m'y coller de nouveau a cette macro..
Neanmoins, pourrais tu m'aider a creer la barre d'avancement ainsi je l'aurais sous la main ..
Merci

[mercatog]

Tout d'abord, regarde ce code (aveuglement adapté à tes fichiers)
Le code permet d'ouvrir le fichier P:\Commun\Transport Securité\Docs Madjid\echanges slm 2011.xls, d'y transférer les données à partir de la feuille Hermes, d'y faire les traitements nécessaires, de l'enregistrer et de le fermer

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
Sub Echange()
Dim Quai As String, Chemin As String, Fichier As String
Dim NbLig As Long, LigDeb As Long, LigFin As Long
Dim Wbk As Workbook, Sh As Worksheet
Dim T As Long
 
T = Timer                                                                                          'Pour tester le temps approximatif d'éxecution
Application.ScreenUpdating = False                                                                 'la mise à jour de l'écran est désactivée
Application.Calculation = xlCalculationManual                                                      'le calcul automatique de la feuille est désactivée
 
Chemin = "P:\Commun\Transport Securité\Docs Madjid"
Fichier = "echanges slm 2011.xls"
 
If Dir(Chemin & "\" & Fichier) <> "" Then
    With ThisWorkbook.Worksheets("Hermes")                                                         'Feuille source de données du classeur contenant la macro
        .AutoFilterMode = False                                                                    'On supprime l'éventuel filtre automatique
        Quai = .Range("C1").Value                                                                  'Cellule de la premiere ligne, seconde colonne soit C1
        NbLig = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set Wbk = Workbooks.Open(Chemin & "\" & Fichier)                                           'On ouvre le fichier P:\Commun\Transport Securité\Docs Madjid\echanges slm 2011.xls
        Set Sh = Wbk.Worksheets("donnees hermes")                                                  'Feuille données hermes du classeur Wbk qui vient d'être ouvert
        Sh.AutoFilterMode = False                                                                  'On supprime l'éventuel filtre automatique
        LigDeb = Sh.Cells(Sh.Rows.Count, "C").End(xlUp).Row + 1                                    'première cellule vide de colonne C de la feuille SH
        LigFin = NbLig + LigDeb - 7                                                                'derniere ligne transférée
        Sh.Range("C" & LigDeb & ":AE" & LigFin).Value = .Range("A6:AC" & NbLig - 1).Value          'On transferts les valeurs de LigDeb:AC de feuille hermes vers C:AE de feuille données hermes
    End With
    With Sh
        With .Range("A" & LigDeb & ":A" & LigFin)
            .Value = Quai
            With .Offset(0, 1)
                .FormulaR1C1 = "=TEXT(RC[1],""mmmm"")"
                .Value = .Value
            End With
        End With
        .Range("AD" & LigDeb & ":AD" & LigFin).FormulaR1C1 = "=RC[-16]+RC[-14]+RC[-8]+RC[-6]"
        .Range("AG" & LigDeb & ":AG" & LigFin).FormulaR1C1 = "=IF(AND(RC[-28]<>""nyk"",RIGHT(RC[-27],2)<>""dp""),IF(RC[-3]>33,""surcapacite"",""""),"""")"
        .Range("AE" & LigDeb & ":AE" & LigFin).Formula = Range("AE3").Formula
        .Range("AF" & LigDeb & ":AF" & LigFin).Formula = Range("AF3").Formula
        .Range("E1").FormulaR1C1 = "=SUBTOTAL(3,R[2]C:R[" & LigFin - 1 & "]C)"
        .Range("N1:X1,AB1,AD1").FormulaR1C1 = "=SUBTOTAL(9,R[2]C:R[" & LigFin - 1 & "]C)"
    End With
    Set Sh = Nothing
    Wbk.Close True
    Set Wbk = Nothing
    MsgBox "Traitement terminé avec succès en " & Timer - T & " secondes..."
Else
    MsgBox "Fichier " & Chemin & "\" & Fichier & " introuvable..."
End If
Application.Calculation = xlCalculationAutomatic
End Sub

[facteur]

Eh ben
Merci Mercatog..
Des lundi, je met en application de cette procedure et je reviens vers toi si je rencontre des soucis...
Bon week end a toi et merci encore

[MattChess]

1. C'est bien Barrée dans la progression

Bon alors maintenant avec la nouvelle version, la barre d'avancement est-elle toujours d'actualité ?

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.

Si le sujet de la barre d'avancement revient dans le forum Excel VBA, c'est qu'il y a plusieurs solutions (UserForm, ProgressBar control et autres variations) combinées à plusieurs modes opératoires pour animer la progression.

On se propose d'afficher la barre de progression dans la barre de status, donc sans UserForm ni ProgressBar control qui peut dépendre de la version ou de l'installation.

L'idée est de lancer une petite animation dans la barre de status sans avoir à se préoccuper de l'affichage du pourcentage d'avancement.

Il n'y a pas de miracle. On ne peut pas deviner à l'avance le temps total de votre longue procédure qui a demandé la barre d'avancement.
Il faudra donc que vous estimiez le temps pendant lequel la barre de status sera animée.

Dans le VBE d'Excel, cliquez sur le menu "Insérer" > "Module"
Dans les propriétés du module, renommez "Module1" en "ModProgressBar".
Copier-coller le code suivant dans la fenêtre d'Edition du module ModProgressBar:

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
Option Explicit
Const pBar_strSub = "ProgressBarUpdate"
 
Dim pBar_nbrTick As Integer, pBar_timeTicker As Integer, pBar_isPercent As Boolean
Dim pBar_strPrompt As String, pBar_strBar As String, pBar_strMsg As String
Dim pBar_timerWakeup As Double, pBar_nbrTickInit As Integer
 
Public Function ProgressBarStart(Optional ByVal nbrTick As Integer = 10, _
                Optional ByVal timeTicker As Integer = 1, _
                Optional ByVal strPrompt As String = "", _
                Optional ByVal isPercent As Boolean = True) As Boolean
 
    ProgressBarStop
    If nbrTick > 0 And timeTicker > 0 Then
        pBar_nbrTick = nbrTick
        pBar_nbrTickInit = nbrTick
        pBar_timeTicker = timeTicker
        pBar_strPrompt = strPrompt
        pBar_strBar = ChrW(9609)
        pBar_isPercent = isPercent
        pBar_strMsg = ""
        ProgressBarUpdate
        ProgressBarStart = True
    Else
        ProgressBarStart = False
    End If
End Function
 
Private Sub ProgressBarSetStsbar()
Dim strMsgBar As String, percent As Integer
 
    If pBar_nbrTick > 0 Then
        strMsgBar = pBar_strPrompt
        If pBar_isPercent Then
            If Len(strMsgBar) > 0 Then
                strMsgBar = strMsgBar + " "
            End If
            percent = (pBar_nbrTickInit - pBar_nbrTick) * 100 \ pBar_nbrTickInit
            strMsgBar = strMsgBar + "(" + Right(" " + Str(percent), 3) + "%) "
        End If
        strMsgBar = strMsgBar + String(pBar_nbrTick, pBar_strBar) + pBar_strMsg
    Else
        strMsgBar = pBar_strMsg
    End If
    Application.StatusBar = strMsgBar
End Sub
 
Private Sub ProgressBarUpdate()
    If pBar_nbrTick > 0 Then
        ProgressBarSetStsbar
        pBar_nbrTick = pBar_nbrTick - 1
        pBar_timerWakeup = Now + TimeSerial(0, 0, pBar_timeTicker)
        Application.OnTime pBar_timerWakeup, pBar_strSub, , True
    Else
        Application.StatusBar = False
    End If
End Sub
 
Public Function ProgressBarGetTickNumber() As Integer
    ProgressBarGetTickNumber = pBar_nbrTick
End Function
 
Public Function ProgressBarGetTickInitial() As Integer
    ProgressBarGetTickInitial = pBar_nbrTickInit
End Function
 
Public Sub ProgressBarSetTickNumber(ByVal nbrTick As Integer)
    If nbrTick > 0 And nbrTick <= pBar_nbrTickInit And pBar_nbrTick > 0 Then
        pBar_nbrTick = nbrTick
        ProgressBarSetStsbar
    End If
End Sub
 
Public Sub ProgressBarStsbar(ByVal strMsg As String)
    pBar_strMsg = strMsg
    ProgressBarSetStsbar
End Sub
 
Public Sub ProgressBarStop()
    If pBar_nbrTick > 0 Then
        pBar_nbrTick = 0
        On Error Resume Next
        Application.OnTime pBar_timerWakeup, pBar_strSub, , False
        On Error GoTo 0
        Application.StatusBar = False
    End If
End Sub

Pour se faire une idée de l'animation de la barre de status avant intégration dans votre longue procédure cible, vous pourrez déclencher directement cette animation depuis la fenêtre d'Exécution immédiate du VBE pour la tester sans aucune boucle.

2. La barre prend de l'avancement

Arranger la fenêtre du VBE de façon qu'elle soit visible au-dessus de la fenêtre de la feuille de calcul sans cacher la barre de status d'Excel puisque le but est d'animer la barre de status.

Dans la fenêtre d'Exécution immédiate (Ctrl+G) du VBE, saisissez l'appel de la procédure qui se retrouvera en tête de votre longue procédure cible demandant une barre de progression :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ProgressBarStart

Dans la barre de status d'Excel, on voit s'afficher un pourcentage ainsi que 10 barres .
( 80%) ||||||||
L'animation dure 10 secondes

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

? ProgressBarStart(20, 1, "Wait...")

True
Ok, les paramètres d'entrée sont corrects. On demande 20 barres avec une animation toutes les secondes.
La barre de status d'Excel présente :
Wait... ( 40%) ||||||||

Coup de barre vers la fin

Si votre longue procédure cible qui tournera en parallèle se termine plus vite que le quota de temps alloué pour l'animation, vous pouvez stopper l'animation à tout moment par :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ProgressBarStop

Appelez ProgressBarStop() généralement à la fin de votre longue procédure cible.

3. Où en est-on ?

On a cherché à rendre l'usage du module ModProgressBar le plus simple possible :
un seul appel suffit : ProgressBarStart 20, 1, "Wait..." 'Animation de la barre de status pendant 20 secondes
L'arrêt par ProgressBarStop() est optionnel.

Le reste qui suit est donc optionnel.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ProgressBarStart 20, 2, "Wait..."

On a demandé 20 barres avec une animation toutes les deux secondes.
Cela laisse le temps d'interroger le nombre de barres, c-a-d la progression courante.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

? ProgressBarGetTickNumber()

17
Cela permettra une éventuelle resynchronisation calculée.

Et ça repart

Supposons que vous savez à l'intérieur de votre longue procédure cible que vous êtes environ à 50% d'exécution selon l'architecture de votre procédure.
Vous pouvez si nécessaire resynchroniser l'animation à tout moment bien sûr avant la fin !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ProgressBarSetTickNumber ProgressBarGetTickInitial() \ 2

Excel affiche dans la barre de status :
Wait... ( 50%) ||||||||||

Vous pouvez ainsi accélérer l'animation ou au contraire lui redonner des quotas de temps si le temps initial s'avère trop court.
Cela donne une certaine flexibilité par rapport au temps d'animation initialement estimé.

La seule restriction est que l'on ne peut pas demander plus de barres qu'au début.
Cependant on peut tout aussi bien relancer ProgressBarStart() avec des paramètres complètement différents même si l'animation courante n'est pas terminée.

4. Plaidoyer à la barre

Et si pendant votre longue procédure cible, vous avez besoin de donner des nouvelles dans la barre de status ?
Pendant que l'animation tourne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ProgressBarStart 20, 2, "Wait..."

on peut à tout moment écrire dans la barre de status avec la procédure suivante :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ProgressBarStsbar " Les rhubarbes barbares trop loubardes se feront rembarrer !"

La barre de status d'Excel montre :
Wait... ( 45%) |||||||||| Les rhubarbes barbares trop loubardes se feront rembarrer !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ProgressBarStsbar "Point barre."

Excel statusbar:
Wait... ( 25%) ||||Point barre.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ProgressBarStop

Excel statusbar:
Ready

[mercatog]

Remplace les lignes 36 et 37 de la réponse #6 par celle ci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

.Range("AE" & LigDeb & ":AF" & LigFin).Formula = .Range("AE3:AF3").Formula

[facteur]

Bonjour mercatog,

je reviens vers toi concernant ton programme :
j'ai commencé à decortiquer cette procedure et je rencontre, dés le début, deux soucis :

1) la feuille source que tu nommes " hermes" est dons mon cas precis, une feuille excel dont le nom change chaque jours. comment y remedier?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
If Dir(Chemin & "\" & Fichier) <> "" Then
    With ThisWorkbook.Worksheets("Hermes")  'Feuille source de données du classeur contenant la macro

.


2) a quoi correspon le chiffre -7

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 LigDeb = Sh.Cells(Sh.Rows.Count, "C").End(xlUp).Row + 1         'première cellule vide de colonne C de la feuille SH
        LigFin = NbLig + LigDeb - 7

Pour une meilleur compréhension , je te joins ( enversion allégé :-), le fichier excel + le fichier "echange slm 2011" qui lui ne change pas de nom.

[mercatog]

Remplace le nom de la feuille par l'index de la feuille (la première feuille)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ThisWorkbook.Worksheets(1)

au lieu de

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ThisWorkbook.Worksheets("Hermes")

Bien sûr le code est mis dans le fichier 2011-07-27-mercredi-DEPART.xls (ce que je doute bien)

Comment tu as prévu de lancer le code?

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
Sub Echange()
Dim Quai As String, Chemin As String, Fichier As String
Dim NbLig As Long, LigDeb As Long, LigFin As Long
Dim Wbk As Workbook, Sh As Worksheet
Dim T As Long
 
T = Timer                                                                                          'Pour tester le temps approximatif d'éxecution
Application.ScreenUpdating = False                                                                 'la mise à jour de l'écran est désactivée
Application.Calculation = xlCalculationManual                                                      'le calcul automatique de la feuille est désactivée
 
Chemin = "P:\Commun\Transport Securité\Docs Madjid"
Fichier = "echanges slm 2011.xls"
 
If Dir(Chemin & "\" & Fichier) <> "" Then
    With ThisWorkbook.Worksheets(1)                                                         'Feuille source de données du classeur contenant la macro
        .AutoFilterMode = False                                                                    'On supprime l'éventuel filtre automatique
        Quai = .Range("C1").Value                                                                  'Cellule de la premiere ligne, seconde colonne soit C1
        NbLig = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set Wbk = Workbooks.Open(Chemin & "\" & Fichier)                                           'On ouvre le fichier P:\Commun\Transport Securité\Docs Madjid\echanges slm 2011.xls
        Set Sh = Wbk.Worksheets("donnees hermes")                                                  'Feuille données hermes du classeur Wbk qui vient d'être ouvert
        Sh.AutoFilterMode = False                                                                  'On supprime l'éventuel filtre automatique
        LigDeb = Sh.Cells(Sh.Rows.Count, "C").End(xlUp).Row + 1                                    'première cellule vide de colonne C de la feuille SH
        LigFin = NbLig + LigDeb - 6                                                                'derniere ligne transférée
        Sh.Range("C" & LigDeb & ":AE" & LigFin).Value = .Range("A6:AC" & NbLig - 1).Value          'On transferts les valeurs de LigDeb:AC de feuille hermes vers C:AE de feuille données hermes
    End With
    With Sh
        With .Range("A" & LigDeb & ":A" & LigFin)
            .Value = Quai
            With .Offset(0, 1)
                .FormulaR1C1 = "=TEXT(RC[1],""mmmm"")"
                .Value = .Value
            End With
        End With
        .Range("AD" & LigDeb & ":AD" & LigFin).FormulaR1C1 = "=RC[-16]+RC[-14]+RC[-8]+RC[-6]"
        .Range("AG" & LigDeb & ":AG" & LigFin).FormulaR1C1 = "=IF(AND(RC[-28]<>""nyk"",RIGHT(RC[-27],2)<>""dp""),IF(RC[-3]>33,""surcapacite"",""""),"""")"
        .Range("AE" & LigDeb & ":AF" & LigFin).Formula = Range("AE3:AF3").Formula
        .Range("E1").FormulaR1C1 = "=SUBTOTAL(3,R[2]C:R[" & LigFin - 1 & "]C)"
        .Range("N1:X1,AB1,AD1").FormulaR1C1 = "=SUBTOTAL(9,R[2]C:R[" & LigFin - 1 & "]C)"
    End With
    Set Sh = Nothing
'    Wbk.Close True
    Set Wbk = Nothing
    MsgBox "Traitement terminé avec succès en " & Timer - T & " secondes..."
Else
    MsgBox "Fichier " & Chemin & "\" & Fichier & " introuvable..."
End If
Application.Calculation = xlCalculationAutomatic
End Sub

le 7 parce que tes données commencent en ligne 7
mais non, sur ton fichier c'est en ligne 6, donc il fallait

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

LigFin = NbLig - 6 + LigDeb

[facteur]

Bonjour Mercatog,

Le code n'est pas mi dans le fichier "2011-07-27-mercredi-DEPART.xls" car ce fichier est archivée aprés avoir été traitée.
Le code est insere dans une fuilel excel intitulé "perso". Et le code est activé par le biais d'un userform.

Pour ce qui est du bon fonctionnement du code, il bug :
Un message apparait sur l'ecran
" une erreur d'exécution 1004; Erreur définie par l'application ou par l'objet".

PS : je te joins uen copie du fichier perso qui contient les macros dont la tienne intitulé "module1"

[SfJ5Rpw8]

sur qu'elle ligne l'erreur

[mercatog]

Bonjour
Tu n'as pas répondu à la question
Tu pilote tes fichiers journaliers type 2011-07-27-mercredi-DEPART.xls et ton fichier d'archivage echanges slm 2011.xls à partir d'un fichier MASTER qui contient le code. C'est ça?
Donc, à partir de ton fichier MASTER, tu dois ouvrir les 2 fichiers journalier et d'archivage pour pouvoir transférer les données.
Si c'est ça, le code devrait être réadapté au nouveau contexte.

[facteur]

Bonjour Mercatog,

Je dois avouer que là, je suis un peu perdu . Et que dois je comprendre lorsque tu dis qu'il faudrait rédapater le code au nouveau contexte
je ne suis pas un pro de vba

[mercatog]

Commence par remplacer la ligne 15 du dernier code par cette ligne, fais le test (éventuellement en pas à pas (F8) pour pouvoir détecter où ça coince)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

With ActiveWorkbook.Worksheets(1)

Si j'ai bien compris, tu as mis le code dans le classeur des macros personnelles

[facteur]

Bonjour Mercatog,

Effectivement le code se trouve dans le classeur des macro personelles.
J'ai donc modifié la ligne 7 mais aussi la ligne 24 où j'ai supprimé le "-1" car la dernier ligne du fichier excel n'etait pas enregistré dans le fichier "echange".
je te remercie vraiment de ton aide.
Je crois que je vais revenir vers toi. Toujours pour ce fichier et avec toujours un problème de barre d'avancement..

[facteur]

Bonjour Mercatog,

Je reviens vers toi concernant ton code sur la barre d'avancement. Celui -ci fonctionne bien mais il bug à la ligne 19 lorsque je lance l'application pour le deuxième fichier hermes.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set Wbk = Workbooks.Open(Chemin & "\" & Fichier) 'On ouvre le fichier P:\Commun\Transport Securité\Docs Madjid\echanges slm 2011.xls

Car j'avais oublié de te preciser que chaque jour, j'ai deux fichiers à traiter et à incrémenter sur le fichier "echange".
Dans ton programme, lorsque je lance le code pour le premier fichier, tout fonctionne. Mais lorsque je lance à nouveau le code pour le deuxième fichier, le programme bug à la ligne 19. Et un cadre s'ouvre à me disant que " le fichier "echange" est déjà ouvert et si je l'ouvre à nouveau, toute sles information seront perdues".

Comment y remedier ?

Merci

[SfJ5Rpw8]

Ben je crois que le message est clair : tu ne peu pas ouvrir 2 fois le fichier "échange" alors
- soit entre temps tu le ferme ...
- soit tu ne l'ouvre pas dans ta deuxième
- soit au lancement de ta macro tu teste s'il est déjà ouvert ..
- soit ....

cela dépend de comment tu lance et enchaine tes 2 codes. ..