Discussion :

[ancel17]

Bonjour,

j'ai le code suivant, avec un temps d'execution assez long.

Code :

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

1
2
3
4
5
6
7
Sub maj()
 
Application.ScreenUpdating = False
...
Application.ScreenUpdating = True
 
End Sub

J'aimerais mettre en place une barre de progression pour rassurer l'utilisateur du non plantage de l'application.

Quelqu'un peut-il m'aider ?

[flo_flo]

Bonjour,

Une petite recherche te mènerait à ce topic.

J'espère que ca t'aidera !

[Invité]

Bonjour Ancel17,

Vous pouvez aussi regarder ici :

http://silkyroad.developpez.com/VBA/...erForm/#LIII-K

[ancel17]

Merci pour vos réponses !

Je suis aller voir l'adresse de jacques_jean, mais je n'arrive pas à obtenir
l'avancement dans la barre de progression

Voici le code utilisé :

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
Option Explicit
Public Const Duree = 10 'secondes
 
Sub maj()
 
UserForm1.Show
Application.OnTime Now + TimeValue("0:0:01"), "MiseAJour"
calcul
 
End Sub
 
Sub calcul()
 
Application.ScreenUpdating = False
 
Dim fso As New FileSystemObject
Dim fich As file
Dim Rep As Folder
Dim Wk As Variant
Dim TabFich() As String
Dim CL1 As Workbook, CL2 As Workbook
Dim FL1 As Worksheet, FL2 As Worksheet
Dim Premlig As Long, Derlig As Long
Dim Nom As String
Dim i As Integer
Dim dmae As String
 
    Set CL1 = ThisWorkbook
    Set FL1 = CL1.Worksheets("Sommaire")
    Set Rep = fso.GetFolder(Application.ThisWorkbook.Path & "\Thèmes")
 
            FL1.Unprotect dmae
            FL1.Range("6:70").Locked = False
            FL1.Range("A74:K65536").Locked = False
            FL1.Rows("74:65536").Delete
 
            For Each fich In Rep.Files
                Wk = Rep & "\" & fich.Name
                If fso.GetExtensionName(Wk) = "xls" Then
                    CL1.Save
                    Premlig = FL1.Range("A65535").End(xlUp).Row + 1
                    Set CL2 = Workbooks.Open(Wk)
                    Set FL2 = CL2.Worksheets("sommaire")
                    Nom = Left(fich.Name, Len(fich.Name) - 4)
                    If Nom = "Air" Or Nom = "Bruit" Or Nom = "Divers" Or Nom = "Hygiène - Sécurité" Or _
                    Nom = "ICPE" Or Nom = "Sites et Sols Pollués" Or Nom = "Substances Radioactives" Then
                        If Not FL2.Range("A15").Value = "" Then
                            FL2.Range("A15:" & FL2.Range("A1"). _
                            SpecialCells(xlCellTypeLastCell).Address).Copy _
                            Destination:=FL1.Range("B" & FL1.Range("B1"). _
                            SpecialCells(xlCellTypeLastCell).Row + 1)
                            Derlig = FL1.Range("A1").SpecialCells(xlCellTypeLastCell).Row
                            For i = Premlig To Derlig
                                FL1.Cells(i, 1).Value = Left(fich.Name, Len(fich.Name) - 4)
                            Next
                        End If
                    Else
                        If Not FL2.Range("A17").Value = "" Then
                            FL2.Range("A17:" & FL2.Range("A1"). _
                            SpecialCells(xlCellTypeLastCell).Address).Copy _
                            Destination:=FL1.Range("B" & FL1.Range("B1"). _
                            SpecialCells(xlCellTypeLastCell).Row + 1)
                            Derlig = FL1.Range("A1").SpecialCells(xlCellTypeLastCell).Row
                            For i = Premlig To Derlig
                                FL1.Cells(i, 1).Value = Left(fich.Name, Len(fich.Name) - 4)
                            Next
                        End If
                    End If
                    CL2.Save
                    CL2.Close
                End If
            Next
 
            If Not FL1.Range("A74").Value = "" Then
                With FL1.Range("A74:" & "K" & FL1.Range("A1").SpecialCells(xlCellTypeLastCell).Row)
                    .VerticalAlignment = xlVAlignCenter
                    '.HorizontalAlignment = xlHAlignCenter
                    .Borders(xlEdgeLeft).LineStyle = xlContinuous
                    .Borders(xlEdgeTop).LineStyle = xlContinuous
                    .Borders(xlEdgeBottom).LineStyle = xlContinuous
                    .Borders(xlEdgeRight).LineStyle = xlContinuous
                    .Borders(xlInsideVertical).LineStyle = xlContinuous
                    If FL1.Range("a1").SpecialCells(xlCellTypeLastCell).Row - 73 > 1 Then
                        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                    End If
                End With
                FL1.Range("A74:" & "A" & FL1.Range("A1").SpecialCells(xlCellTypeLastCell).Row).HorizontalAlignment = xlHAlignCenter
            End If
 
        FL1.Range("A74:K65536").Locked = True
        FL1.Protect dmae, UserInterfaceOnly:=True, AllowFiltering:=True
 
    Set Rep = Nothing
    Set FL1 = Nothing
    Set CL1 = Nothing
    Set FL2 = Nothing
    Set CL2 = Nothing
    Application.ScreenUpdating = True
 
End Sub
 
Sub Demarrer()
    Application.OnTime Now + TimeValue("0:0:01"), "MiseAJour"
End Sub
 
Sub MiseAJour()
 
    If UserForm1.ProgressBar1.Value = Duree Then
        Unload UserForm1
        Exit Sub
        Else
        UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1
    End If
 
    Call Demarrer
End Sub

j'aimerai baser ma barre de progression sur la sub "calcul"

Mais que fait "calcul" ?

elle liste tous les fichiers .xls d'un répertoire donné
elle ouvre ensuite chaque fichier listé, copie la plage "A15:Xn" ou "A17:Xn" avec Xn l'adresse de la dernière cellule, colle la plage copié sur la plage qui va bien
elle affecte à la première colonne le nom du fichier origine et encadre les cellules

Comment faire ?

[rtg57]

Personnellement, je me méfie des contrôles qui sortent un peu de l'ordinaire.
J'ai eu des surprises avec des applications construites avec des composants récents. Lorsque j'essayais de les faire fonctionner sur des versions EXCEL un peu plus anciennes, ou pas équipées de toutes les bibliothèques de composants, cela ne fonctionnait pas.
Alors j'ai utilisé une astuce:
J'ai réduis la largeur de plusieurs cellules, et j'ai programmé une mise en forme conditionnelle dans chacune d'elles. (Evidemment, faut une version d'EXCEL qui prenne en charge cette fonctionnalité )
La mise en forme fait changer la couleur des cases en fonction de la valeur contenue dans une cellule. Cette cellule est incrémentée avec l'état d'avancement des calculs.
Cela m'a même permis de faire un bargraphe double-couleur:
Vert très foncé lorsque les "leds" sont éteintes.
Vert moyen lors de la première phase de calculs
Vert vif lors de la seconde phase de calculs.

On peut encore imaginer d'autres choses... Des fois la solution n'est pas là où l'on croit.

[Invité]

Bonjour Ancel17,

Je viens de télécharger le fichier exemple créé par SilkyRoad.

Dans votre cas vous pouvez dans :

Code :

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

1
2
3
4
5
6
Sub Demarrer()
    Application.OnTime Now + TimeValue("00:00:01"), "MiseAJour"
 
ajouter 
 
Call Calcul

Si vous le désirez vous pouvez aussi supprimer la procédure "Lancer" et copier

Code :

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

UserForm1.Show

au début de la procédure "Calcul".

Ensuite si vous voulez un démarrage immédiat, supprimer le Commandbutton1 dans le formulaire et supprimer dans le code du formulaire :

Code :

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

1
2
3
4
5
Private Sub CommandButton1_Click()
    CommandButton1.Enabled = False
    Label1 = Duree
    Call Demarrer
End Sub

et ajouter :

Code :

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

1
2
Label1 = Duree
    Call Demarrer

sous End With dans Private Sub UserForm_Initialize()

En fonction de la durée de traitement de votre procédure Calcul il vous reste à régler les paramètres numériques : Durée, Max, Min etc, et de faire des essais car avec des paramètres erronés vous risquez d'augmenter considérablement le temps de traitement (j'ai fait des essais).
Avec la version 2000 je n'ai pas accès à l'aide pour ces réglages et si j'ai déjà fait ce genre de chose, c'était il y a plus de 20 ans avec un langage de programmation fonctionnant sous Dos.

Bon courage.

[ancel17]

Voilà où j'en suis :

j'ai remplacé

Code :

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

1
2
3
Application.ScreenUpdating = False
par
Application.WindowState = xlMinimized

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
Option Explicit
Public Const Duree = 75 'secondes
---------------------------------------------------------------------
Sub maj()
 
UserForm1.Show
    With UserForm1.ProgressBar1
        .Min = 0
        .Max = Duree
        .Value = 0
    End With
    Call Demarrer
 
Application.WindowState = xlMinimized
 
Dim fso As New FileSystemObject
Dim fich As file
Dim Rep As Folder
Dim Wk As Variant
Dim TabFich() As String
Dim CL1 As Workbook, CL2 As Workbook
Dim FL1 As Worksheet, FL2 As Worksheet
Dim Premlig As Long, Derlig As Long
Dim Nom As String
Dim i As Integer
Dim dmae As String
 
    Set CL1 = ThisWorkbook
    Set FL1 = CL1.Worksheets("Sommaire")
    Set Rep = fso.GetFolder(Application.ThisWorkbook.Path & "\Thèmes")
 
            FL1.Unprotect dmae
            FL1.Range("6:70").Locked = False
            FL1.Range("A74:K65536").Locked = False
            FL1.Rows("74:65536").Delete
 
            For Each fich In Rep.Files
                Wk = Rep & "\" & fich.Name
                If fso.GetExtensionName(Wk) = "xls" Then
                    CL1.Save
                    Premlig = FL1.Range("A65535").End(xlUp).Row + 1
                    Set CL2 = Workbooks.Open(Wk)
                    Set FL2 = CL2.Worksheets("sommaire")
                    FL2.Visible = True
                    Nom = Left(fich.Name, Len(fich.Name) - 4)
                    If Nom = "Air" Or Nom = "Bruit" Or Nom = "Divers" Or Nom = "Hygiène - Sécurité" Or _
                    Nom = "ICPE" Or Nom = "Sites et Sols Pollués" Or Nom = "Substances Radioactives" Then
                        If Not FL2.Range("A15").Value = "" Then
                            FL2.Range("A15:" & FL2.Range("A1"). _
                            SpecialCells(xlCellTypeLastCell).Address).Copy _
                            Destination:=FL1.Range("B" & FL1.Range("B1"). _
                            SpecialCells(xlCellTypeLastCell).Row + 1)
                            Derlig = FL1.Range("A1").SpecialCells(xlCellTypeLastCell).Row
                            For i = Premlig To Derlig
                                FL1.Cells(i, 1).Value = Left(fich.Name, Len(fich.Name) - 4)
                            Next
                        End If
                    Else
                        If Not FL2.Range("A17").Value = "" Then
                            FL2.Range("A17:" & FL2.Range("A1"). _
                            SpecialCells(xlCellTypeLastCell).Address).Copy _
                            Destination:=FL1.Range("B" & FL1.Range("B1"). _
                            SpecialCells(xlCellTypeLastCell).Row + 1)
                            Derlig = FL1.Range("A1").SpecialCells(xlCellTypeLastCell).Row
                            For i = Premlig To Derlig
                                FL1.Cells(i, 1).Value = Left(fich.Name, Len(fich.Name) - 4)
                            Next
                        End If
                    End If
                    CL2.Close SaveChanges:=True
                End If
            Next
 
            If Not FL1.Range("A74").Value = "" Then
                With FL1.Range("A74:" & "K" & FL1.Range("A1").SpecialCells(xlCellTypeLastCell).Row)
                    .VerticalAlignment = xlVAlignCenter
                    '.HorizontalAlignment = xlHAlignCenter
                    .Borders(xlEdgeLeft).LineStyle = xlContinuous
                    .Borders(xlEdgeTop).LineStyle = xlContinuous
                    .Borders(xlEdgeBottom).LineStyle = xlContinuous
                    .Borders(xlEdgeRight).LineStyle = xlContinuous
                    .Borders(xlInsideVertical).LineStyle = xlContinuous
                    If FL1.Range("a1").SpecialCells(xlCellTypeLastCell).Row - 73 > 1 Then
                        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                    End If
                End With
                FL1.Range("A74:" & "A" & FL1.Range("A1").SpecialCells(xlCellTypeLastCell).Row).HorizontalAlignment = xlHAlignCenter
            End If
 
        FL1.Range("A74:K65536").Locked = True
        FL1.Protect dmae, UserInterfaceOnly:=True, AllowFiltering:=True
 
    Set Rep = Nothing
    Set FL1 = Nothing
    Set CL1 = Nothing
    Set FL2 = Nothing
    Set CL2 = Nothing
    Application.WindowState = xlMaximized
 
End Sub
----------------------------------------------------------------------
Sub Demarrer()
 
    Application.OnTime Now + TimeValue("0:0:01"), "MiseAJour"
 
End Sub
-----------------------------------------------------------------------
Sub MiseAJour()
 
    If UserForm1.ProgressBar1.Value = Duree Then
        Unload UserForm1
        Exit Sub
        Else
        UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1
    End If
    Call Demarrer
 
End Sub

Je voudrais que l'évolution de la barre de progression se face en même temps que l'ancienne sub "calcul" qui se trouve maintenant dans la sub maj, à la suite de

Code :

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

1
2
3
4
5
6
7
UserForm1.Show
    With UserForm1.ProgressBar1
        .Min = 0
        .Max = Duree
        .Value = 0
    End With
    Call Demarrer

[ancel17]

Obsolète, je clos la discussion...