Barre de progression

[Nazim]

Bonjour,
J'ai crée la macro suivante afin de faire certains retraitements ( ouvrir un fichier excel dans une feuille, et copier son contenu suivant certaines valeurs dans 3 feuilles différentes, j'avoue que mon fichier est un peu volumineux donc le process prend du temps)

Je veux faire une barre de progression qui se termine une fois toutes les copies effectuées.

Puis-je avoir de l'aide ?

Merci
Voici ma macro


Sub ImportData()

Application.DisplayAlerts = False


Sheets("general_report").Cells.Clear
Sheets("general_report").Delete
Application.DisplayAlerts = True
Dim wBase As Workbook, wOuvert As Workbook, WS As Worksheet
Set wBase = ThisWorkbook
If Not Application.Dialogs(xlDialogOpen).Show Then Exit Sub
Set wOuvert = ActiveWorkbook
For Each WS In wOuvert.Worksheets
WS.Copy After:=wBase.Worksheets(wBase.Worksheets.Count)
Next WS
wOuvert.Close False



'********************************************Data sauvegarde**************************************
Dim LePath As String, LeNom As String, LePath2 As String
strDate = Format(Now, "dd-mm-yy hh-mm")
LePath2 = ActiveWorkbook.Path & "\Archive\"

Sheets("general_report").Copy
LeNom = strDate & ".xls"
ActiveWorkbook.SaveAs LePath2 & "Data " & LeNom
ActiveWorkbook.Close

'********************************************Retraitement******************************************


Sheets("general_report").Activate

Sheets("general_report").Rows(1).Delete
Sheets("general_report").Rows(2).Delete
Sheets("general_report").Rows(3).Delete
'Sheets("general_report").Rows(5).Delete
Sheets("general_report").Rows(1).Delete

Cells.Font.Size = 8

'***********************************Delivery Backlog**************************************************
Dim LLig As Long
Dim buffer, ligne
tablo = Sheets("general_report").UsedRange.Value
p = 2
i = 2
For l = 2 To UBound(tablo)
Sheets("general_report").Activate
buffer = Sheets("general_report").Cells(p, 12)
If buffer = "Done" Then
ligne = Sheets("general_report").Rows(p)
Sheets("Delivery Backlog").Activate
Sheets("Delivery Backlog").Rows(i) = ligne
i = i + 1
End If
p = p + 1
Next l
Sheets("Delivery Backlog").Activate
Cells.Font.Size = 8

'***********************************Backlog Catalogue**************************************************
' Dim LLig As Long
' Dim buffer, ligne
tablo = Sheets("general_report").UsedRange.Value
p = 2
i = 2
For l = 2 To UBound(tablo)
Sheets("general_report").Activate
buffer = Sheets("general_report").Cells(p, 12)
If buffer = "To Do" Or buffer = "General Spec Done" Or buffer = "Ready for Specification" Then
ligne = Sheets("general_report").Rows(p)
Sheets("Delivery Backlog").Activate
Sheets("Backlog Catalogue").Rows(i) = ligne
i = i + 1
End If
p = p + 1
Next l
Sheets("Backlog Catalogue").Activate
Cells.Font.Size = 8

'***********************************Used In Prod**************************************************
' Dim LLig As Long
' Dim buffer, ligne
tablo = Sheets("general_report").UsedRange.Value
p = 2
i = 2
For l = 2 To UBound(tablo)
Sheets("general_report").Activate
buffer = Sheets("general_report").Cells(p, 12)
If buffer = "USED IN PRODUCTION" Or buffer = "In Progress" Or buffer = "Peer review" Or buffer = "Dev - In Progress" Or buffer = "Prioritized" Or buffer = "PreUAT" Or buffer = "SIT" Then
ligne = Sheets("general_report").Rows(p)
Sheets("Used In Prod").Activate
Sheets("Used In Prod").Rows(i) = ligne
i = i + 1
End If
p = p + 1
Next l
Sheets("Used In Prod").Activate
Cells.Font.Size = 8
End Sub

 

[jeanba]

Bonjour Dranreb, Bonjour à tous!

C'est une histoire de fou je dirais...
J'ai suivi pas à pas ce que tu as fait:

1. Création de l'usf nommé UFmBarProg

Code de l'userform ainsi créé:

Option Explicit
Public AbandonDemandé As Boolean
Private ZUn As String, Hysté As Long
Public Sub Afficher(Unités As String)
    Caption = NomTâche: Hysté = 0
    Position 0: LbAct.Visible = False
    With LbTemps: .Caption = "Lancé à " & Format(Now, "h""h.""m")
       .BackStyle = fmBackStyleTransparent: .ForeColor = &HFF0000: End With
    ZUn = " " & Unités & "/sec."
    AbandonDemandé = False
    Me.Show
    DoEvents
End Sub
Public Sub Actualiser(FréqAct As Long, ByVal DuréeJusqueLà As Double)
    Dim LarAct As Double, Durée1Pix As Double, Heure As Date, HeureFin As Date
    Const InvLog10×60 = 60# * 103910846 / 239263565
    LbAct.Visible = FréqAct > 0
    If LbAct.Visible Then
       LarAct = Log(FréqAct) * InvLog10×60
       Select Case LarAct + Hysté:
          Case Is < 60:  Hysté = 60 * Int(1 - LarAct / 60)
          Case Is > 180: Hysté = 60 * Int(2 - LarAct / 60): End Select
       LbAct.Width = LarAct + Hysté
       LbAct.Caption = FréqAct & ZUn
       End If
    Position NbPixFaits / NbPixÀFaire
    Durée1Pix = DuréeJusqueLà / NbPixFaits
    Heure = Now: HeureFin = Heure + Durée1Pix * (NbPixÀFaire - NbPixFaits)
    LbTemps.Caption = "Fin prévue à " & Format(HeureFin, "h""h.""mm") _
       & " (dans" & Replace(" " & Format(HeureFin - Heure, "h:mm:ss"), " 0:", " ") & ")"
    DoEvents
End Sub
Public Sub Terminer()
    Position 1: LbAct.Visible = False: LbTemps.Caption = "Terminé !"
End Sub
Private Sub Position(ByVal Prc As Double)
    ImgBarre.Left = 150 * Prc - 141
    LbAv.Caption = Round(100 * Prc) & " %"
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode > vbFormControlMenu Then Exit Sub
    If NbPixFaits >= NbPixÀFaire Then MBarreProg.MasquerUFmBarProg True: Exit Sub
        Cancel = True
    If MBarreProg.AbandonInterdit Then Exit Sub
        LbAct.Visible = False
    With LbTemps: .Caption = "ABANDON DEMANDÉ.":
       .BackStyle = fmBackStyleOpaque: .ForeColor = &HFFFF&: End With
    Me.AbandonDemandé = True
End Sub

2. Création d'un module intitulé MBarreProg

Code du module ainsi créé:

Option Explicit
Public NomTâche As String, AbandonInterdit As Boolean, AbandonDemandé As Boolean, NbPixÀFaire As Long, NbPixFaits As Long
Private Heure As Date
Private MomentDébut As Double, Top As Long, Cycle As Long, Secondes(1 To 4) As Single, NbPixF1Sec(1 To 4) As Long
'

Rem. —— Affichage de la barre d'avancement
Sub Tâche(Optional ByVal Texte As String = "", Optional ByVal NbrPrévus As Long = 0, Optional ByVal Unités As String = "opé.")
' Texte:     Texte court du titre de la fenêtre de la barre d'avancement.
' NbrPrévus: Nombre d'appels à effectuer de la procédure OùÇaEnEst
' Unités:    Nature de ce qui est traité dans la boucle.
If Texte <> "" Then NomTâche = Texte
MomentDébut = VBA.Timer: Top = Int(4 * MomentDébut)
NbPixFaits = 0: NbPixÀFaire = NbrPrévus
UFmBarProg.Afficher Unités
For Cycle = 1 To 4: Secondes(Cycle) = MomentDébut: NbPixF1Sec(Cycle) = 0: Next Cycle: Cycle = 1
AbandonDemandé = False
If Heure <> 0 Then Application.OnTime Heure, "MasquerUFmBarProg", Schedule:=False: Heure = 0
End Sub
'

Rem. —— Suivi de la progression à exécuter impérativement autant de fois que spécifié à l'appel de Tâche.
'       Le plus souvent, ne fait qu'incrémenter le compteur, l'aspect de la barre n'étant rectifié que tous les 1/4 seconde
'       ce qui est le temps minmum nécessaire pour arriver à lire au moins une des informations affichées.
Sub OùÇaEnEst()
Dim Temps As Single, Tip As Long, Durée As Double
NbPixFaits = NbPixFaits + 1
Temps = VBA.Timer: Tip = Int(4 * Temps)
If NbPixFaits > NbPixÀFaire Then
   MsgBox "ÇaEnEst… à + des " & NbPixÀFaire & " passages prévus !" & vbLf & "Examiner pile appels.", vbCritical, NomTâche: Stop: End
ElseIf NbPixFaits >= NbPixÀFaire Then
   UFmBarProg.Terminer
   Heure = Now + TimeSerial(0, 0, 2): Application.OnTime Heure, "MasquerUFmBarProg"
ElseIf UFmBarProg.AbandonDemandé Then
   AbandonDemandé = True: NbPixÀFaire = 0
   Heure = Now + TimeSerial(0, 0, 3): Application.OnTime Heure, "MasquerUFmBarProg"
ElseIf Tip <> Top Then
   If Temps < MomentDébut Then MomentDébut = MomentDébut - 86400 'secondes
   Durée = Temps - Secondes(Cycle): If Durée < 0 Then Durée = Durée + 86400 'secondes
   UFmBarProg.Actualiser FréqAct:=(NbPixFaits - NbPixF1Sec(Cycle)) / Durée, _
      DuréeJusqueLà:=(Temps - MomentDébut) / 86400 'DuréeTot
   Secondes(Cycle) = Temps: NbPixF1Sec(Cycle) = NbPixFaits: Cycle = Cycle Mod 4 + 1
   Top = Tip: End If
End Sub
'

Sub MasquerUFmBarProg(Optional ByVal Forcé As Boolean)
If Forcé Then Application.OnTime Heure, "MasquerUFmBarProg", Schedule:=False Else UFmBarProg.Hide
Heure = 0
End Sub

3. Enfin, dans le module 1, Code de la procédure devant appeler l'userform UFmBarProg:

Sub JnalGeneral()
Dim wsh As Worksheet, derlig&, xrg As Range, NbPass As Long

Application.ScreenUpdating = False
Worksheets("Centralisation").Range("A2:I" & Rows.Count).ClearContents  'Sur la feuille de destination, le collage débute de la cellule A2 à la colonne I 

    For Each wsh In ThisWorkbook.Worksheets
        If IsDate("1-" & wsh.Name) Then
            If Len(wsh.Range("A8")) > 0 Then NbPass = NbPass + 1
        End If
    Next wsh
    Tâche "MàJ", NbPass, "opé."
    For Each wsh In ThisWorkbook.Worksheets
        If IsDate("1-" & wsh.Name) Then
            If Len(wsh.Range("A8")) > 0 Then          ' Sur les feuilles de données source, les données à copier débutent à la ligne A8
                With Worksheets("Centralisation")
                    derlig = wsh.Cells(Rows.Count, "A").End(xlUp).Row
                    If derlig > 2 Then
                        Set xrg = .Cells(Rows.Count, "B").End(xlUp).Offset(1)
                        wsh.Range("A8:H" & derlig).Copy            ' Sur les feuilles de données source, les données à copier débutent à la ligne A8 jusqu'à la colonne H
                        xrg.PasteSpecial Paste:=xlPasteValues
                        xrg.Offset(, -1).Resize(wsh.Range("A8:H" & derlig).Rows.Count) = Month("1-" & wsh.Name)
                    End If
                    CouleurLignes
                End With
                OùÇaEnEst
            End If
        End If
    Next wsh
End Sub

Sub CouleurLignes()
  Dim sht$
  DeverrouillerFeuille
  sht$ = ActiveSheet.Name
  Application.ScreenUpdating = False
  couleur = 2
  If sht$ = "Centralisation" Then
        For I = 2 To [A65000].End(xlUp).Row
            If Cells(I, 1) <> Cells(I - 1, 1) Then couleur = IIf(couleur = 2, 15, 2)
            Cells(I, 1).Resize(, 8).Interior.ColorIndex = couleur
            Range("A2").Activate
        Next I
  Else
        If ActiveSheet.Name <> "ACCUEIL" Then
            RéinitialiseCouleur
            For I = 8 To [A65000].End(xlUp).Row           ' Sur les feuilles de données source, les données à copier débutent à la ligne 8
                If Cells(I, 1) <> Cells(I - 1, 1) Then couleur = IIf(couleur = 2, 15, 2)
                Cells(I, 1).Resize(, 12).Interior.ColorIndex = couleur
                Range("A8").Select
            Next I
        End If
  Application.ScreenUpdating = True
  End If
End Sub

4. Pour ce résultat:

Et pour l'arrêter, il faut que j'arrête la macro par le bouton ARRET dans VBE!!

Alors, s'il y a quelque chose que j'ai pas fait, je veux bien corriger et passer à autre chose...
Au passage, je signale que si je désactive les lignes de code qui font appel à la barre de progression, la macro s'exécute sans souci...

Merci encore pour tout!

Jeanba

 

[Dranreb]

Il vaudrait mieux me joindre le classeur qui ne marche pas.
Vous parlez toujours de création de ceci et cela…
Mais en réalité vous avez bien simplement glissé, j'espère, dans l'explorateur de projet, les deux composants fournis, depuis mon projet VBA vers le vôtre.
Parce que si vous les avez un peu recréés pièce par pièce, vous pourriez avoir oublié un tas de détails, comme par exemple de mettre la propriété ShowModal de UFmBarProg à False…

 

[HONORE M.A.H.J]

Bonjour,
Barre de progression...suite...fonctionne correctement avec Excel 2007!
Cordialement,
HONORE

BONNE ANNÉE 2007,
BONNE SANTÉ,
Je vous souhaite une année de bonheur et de prospérité,
Que vos vœux les plus optimistes soient comblés, vos efforts récompensés.

 

[Lone-wolf]

Bonjour et bonne année à tous avec un peu de retard

un autre exemple de barre de progression à améliorer. Cliquer sur l'image du bouton de la barre des tâches.