Comment synchroniser ma barre de progression a ma macro

Le 30/05/2018 à 02:06

Bonjour

Je n'arrive pas a raccorder ma barre de progression lier au temps d"execution de ma macro qui travail sur un fichier excel et une base access

si vous avez une solution d'optimisation de macro pour finaliser mon fichier

merci d'avance

Cordialement

40durdur.xlsm (57.78 Ko)
Le 30/05/2018 à 07:16

Bonjour,

Une piste mais avant tout, il faut que tu ouvres ta Form en non modale car sinon, elle garde le focus :

Sub Test()

    Dim I As Long

    Set ProgressIndicator = New UserForm100

    With ProgressIndicator

        .Show False
        .LabelProgress.Width = 0

    End With

    For I = 1 To 100

        BarreDeProgression I, 100 '<--- pour le test, mettre un point d'arrêt ici et appuis successifs sur F5
                                   'réduire la fenêtre pour faire apparaîre la form !
    Next I

    Unload ProgressIndicator

End Sub

Sub BarreDeProgression(ByVal Valeur As Double, _
                       ByVal Maxi As Double)

    Dim R As Double

    With ProgressIndicator

        R = (.FrameProgress.Width - 8) / Maxi

        .FrameProgress.Caption = Format(Valeur / Maxi, "0%")
        .LabelProgress.Width = Valeur * R

    End With

    DoEvents

End Sub

Comme ta procédure avance pas à pas, il te faut appeler la Sub "BarreDeProgression()" entre chaque pas :

Sub Enter()
    Dim Counter As Integer
    Dim PctDone As Single
    Dim sh As Worksheet
    Dim nomFichier
    Dim compteur, I

    Dim Increment As Integer 'pour la progression

    Set ProgressIndicator = New UserForm100

    ProgressIndicator.Show False

    If TypeName(ActiveSheet) <> "Worksheet" Then
        Unload ProgressIndicator
        Exit Sub
    End If

    Counter = 1

    Increment = 1
    BarreDeProgression Increment, 100 '<--- 1er appel

On Error Resume Next

    nomFichier = Range("A1")
    Workbooks.Open Filename:="C:\Users\Abdessamad\Documents\Accèsfournisseurs.xlsx"
    Application.DisplayAlerts = False

For Each sh In ActiveWorkbook.Sheets
    If Not sh.Name = "Liste fournisseurs nationaux 17" Then sh.Delete
Next

    Increment = Increment + 1
    BarreDeProgression Increment, 100 '<--- 2ème appel

Application.DisplayAlerts = True
    Sheets("Liste fournisseurs nationaux 17").Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Columns("A:A").Select

    Increment = Increment + 1
    BarreDeProgression Increment, 100 '<--- 3ème appel

    Selection.Insert Shift:=xlToRight
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    Increment = Increment + 1
    BarreDeProgression Increment, 100 '<---4ème appel
    'etc...
    '...
    '...

Il faut que le nombre d'appels ne puissent dépasser le maximum passé à la procédure ici, 100 (tu peux n'en faire que 10 si tu le souhaites !

Le 30/05/2018 à 12:10
Theze a écrit :

Bonjour,

Une piste mais avant tout, il faut que tu ouvres ta Form en non modale car sinon, elle garde le focus :

Sub Test()

    Dim I As Long

    Set ProgressIndicator = New UserForm100

    With ProgressIndicator

        .Show False
        .LabelProgress.Width = 0

    End With

    For I = 1 To 100

        BarreDeProgression I, 100 '<--- pour le test, mettre un point d'arrêt ici et appuis successifs sur F5
                                   'réduire la fenêtre pour faire apparaîre la form !
    Next I

    Unload ProgressIndicator

End Sub

Sub BarreDeProgression(ByVal Valeur As Double, _
                       ByVal Maxi As Double)

    Dim R As Double

    With ProgressIndicator

        R = (.FrameProgress.Width - 8) / Maxi

        .FrameProgress.Caption = Format(Valeur / Maxi, "0%")
        .LabelProgress.Width = Valeur * R

    End With

    DoEvents

End Sub

Comme ta procédure avance pas à pas, il te faut appeler la Sub "BarreDeProgression()" entre chaque pas :

Sub Enter()
    Dim Counter As Integer
    Dim PctDone As Single
    Dim sh As Worksheet
    Dim nomFichier
    Dim compteur, I

    Dim Increment As Integer 'pour la progression

    Set ProgressIndicator = New UserForm100

    ProgressIndicator.Show False

    If TypeName(ActiveSheet) <> "Worksheet" Then
        Unload ProgressIndicator
        Exit Sub
    End If

    Counter = 1

    Increment = 1
    BarreDeProgression Increment, 100 '<--- 1er appel

On Error Resume Next

    nomFichier = Range("A1")
    Workbooks.Open Filename:="C:\Users\Abdessamad\Documents\Accèsfournisseurs.xlsx"
    Application.DisplayAlerts = False

For Each sh In ActiveWorkbook.Sheets
    If Not sh.Name = "Liste fournisseurs nationaux 17" Then sh.Delete
Next

    Increment = Increment + 1
    BarreDeProgression Increment, 100 '<--- 2ème appel

Application.DisplayAlerts = True
    Sheets("Liste fournisseurs nationaux 17").Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Columns("A:A").Select

    Increment = Increment + 1
    BarreDeProgression Increment, 100 '<--- 3ème appel

    Selection.Insert Shift:=xlToRight
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    Increment = Increment + 1
    BarreDeProgression Increment, 100 '<---4ème appel
    'etc...
    '...
    '...

Il faut que le nombre d'appels ne puissent dépasser le maximum passé à la procédure ici, 100 (tu peux n'en faire que 10 si tu le souhaites !

Re

j'ai fais le teste ok

cette ligne plante

R = (.FrameProgress.Width - 8) / Maxi
Le 30/05/2018 à 14:55

Re,

Si "ProgressIndicator" est déclarée en tête de module et initialisée avant l'appel de la sub "BarreDeProgression " il n'y a pas de raison que ça ne fonctionne pas. Un exemple avec des appels successifs entre chaque boucle :

Dim ProgressIndicator As UserForm100 '<--- déclarée en tête de module (c'est ce que tu as fait !)

Sub Test2()

    Dim I As Integer

    Set ProgressIndicator = New UserForm100

    With ProgressIndicator

        .Show False
        .LabelProgress.Width = 0

    End With

    BarreDeProgression 1, 10

    For I = 1 To 1000
        Range("A1").Value = I
    Next I

    BarreDeProgression 2, 10

    For I = 1 To 1000
        Range("B1").Value = I
    Next I

    BarreDeProgression 3, 10

    For I = 1 To 1000
        Range("C1").Value = I
    Next I

    BarreDeProgression 4, 10

    For I = 1 To 1000
        Range("D1").Value = I
    Next I

    BarreDeProgression 5, 10

    For I = 1 To 1000
        Range("E1").Value = I
    Next I

    BarreDeProgression 6, 10
    For I = 1 To 1000
        Range("F1").Value = I
    Next I

    BarreDeProgression 7, 10
    For I = 1 To 1000
        Range("G1").Value = I
    Next I

    BarreDeProgression 8, 10
    For I = 1 To 1000
        Range("H1").Value = I
    Next I

    BarreDeProgression 9, 10

    For I = 1 To 1000
        Range("I1").Value = I
    Next I

    BarreDeProgression 10, 10

    Unload ProgressIndicator

End Sub

Sub BarreDeProgression(ByVal Valeur As Double, _
                       ByVal Maxi As Double)

    Dim R As Double

    With ProgressIndicator

        R = (.FrameProgress.Width - 8) / Maxi

        .FrameProgress.Caption = Format(Valeur / Maxi, "0%")
        .LabelProgress.Width = Valeur * R

    End With

    DoEvents

End Sub
Le 31/05/2018 à 00:42

Re

tous fonctionne parfaitement

merci beaucoup pour le coup de main

Cordialement

Rechercher des sujets similaires à "comment synchroniser barre progression macro"