compteur progression exécution macro

Bonjour ,à Tous!

Voulant faire tester une application VBA à mes collègues, l'un d'eux m'a fait remarquer la longueur d'exécution de celle ci. Je voudrais afficher un USF indiquant le progrès du travail en cours...

J'ai trouvé ceci, qui me parait pertinent:

Code:

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
Private Sub CommandButton1_Click()
 
    'Macro : Sébastien Mathier '
 
    Application.ScreenUpdating = False
 
    UserForm_demo.Height = 121.5
 
    compteur = 0
    progression = 0
 
    For ligne = 1 To 5000
        For col = 1 To 50
 
            compteur = compteur + 1
            Cells(ligne, col) = ligne + col
 
            If compteur Mod 2500 = 0 Then '=> sera exécuté 100x
 
                progression = progression + 1
                Image_barre.Width = progression * 1.5
                Label_barre.Caption = progression & "%"
                DoEvents
 
            End If
 
        Next
    Next
 
    Application.ScreenUpdating = True
    UserForm_demo.Height = 136.5
 
End Sub

et j'apprécierai l'intégrer à cela, entre For i et Next i :

Code:

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
Sub Misenpage()
 
    Dim feuil As Worksheet
    Dim Rg As Range, Rg1 As Range
    Dim Expression As String
    Dim i As Long
    Expression1 = ""
    Expression2 = "A-NOMENCLATURE DES INSTALLATIONS CLASSEES"
 
 
    With Worksheets("Legifrance") 'Nom de la feuille à adapter
        Set Rg = .Cells.Find(what:=Expression1, LookIn:=xlValues, lookat:=xlWhole)
        Set Rg1 = .Cells.Find(what:=Expression2, LookIn:=xlValues, lookat:=xlWhole)
 
        If Not Rg Is Nothing Then
            'Supprime la plage de cellules
            .Range(Rg, Rg1).EntireRow.Delete
        End If
 
        For i = Range("A" & Rows.Count).End(xlUp).Row To 10 Step -1  
             If Cells(i, 2) = "" Then
             Cells(i, 2).EntireRow.Delete
              End If
              If Cells(i, 2) = "A-NOMENCLATURE DES INSTALLATIONS CLASSEES" Then
             Cells(i, 2).EntireRow.Delete
              End If
              If Cells(i, 2) = "Désignation de la rubrique" Then
             Cells(i, 2).EntireRow.Delete
              End If
                If Cells(i, 3).MergeCells Then
                Cells(i, 3).MergeCells = False
                End If
       Next i
 
 
        For Each Img In Sheets("Legifrance").Pictures
            Img.Delete
        Next Img
 
    End With
 
End Sub

Mon problème est que mes différents essais m'ont , au mieux permis d'afficher l'USF contenant une barre de progression fixe (soit pleine, soit vide)... pas moyen de calibrer le compteur selon mes données!

Help?

Merci!