Barre de progression

Nazim · 4 Mai 2016

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

Dranreb · 20 Décembre 2016

Bonsoir.

Je ne trouve pas le code mentionné dans le classeur joint ?

Ma programmation n'était qu'un exemple pour montrer qu'on doit mettre Tâche Titre, NbPassagesPrévus, "opé." juste avant la boucle et OùÇaEnEst à la fin de chaque passage.

jeanba · 20 Décembre 2016

Bonsoir Dranreb,

Je me doutais que mon message serait pas assez clair.
Le fichier joint ne contient pas la macro reproduit. Il contient plutôt l'USF pour message d'attente avec barre de progression que j'ai chopé sur le site Microsoft.
Je souhaite insérer cette usf dans mon algo de telle sorte qu'elle puisse s'afficher pendant l'exécution de ma macro que j'ai mentionnée plus haut, en fait je sais pas 1) à quel niveau la mettre. J'ai pensé l'insérer juste après "Unload Me". Mais, il se trouve qu'elle est conçue pour écrire dans des cellules d'une feuille et 2) moi je veux pas de cela. Je veux qu'elle s'affiche pendant que ma macro à moi s'exécuterait.
Je sais pas si c'est un peu plus clair pour toi...?

Dranreb · 20 Décembre 2016

Ma solution n'utilise pas ça, elle est conçue pour n'importe quelle macro à vous. L'UserForm UFmBarProg n'effectue rien du travail à surveiller, il se borne à afficher son avancement d'après une procédure OùÇaEnEst qui doit être appelée autant de fois, dans le processus de cette macro, qu'il a été annoncé, à son début, à une procédure Tâche.
Si le nom de la Sub OùÇaEnEst vous parait trop loufoque vous pouvez toujours lui mettre un autre nom, mais au moins avec celui ci, on ne risque pas d'oublier à quoi elle sert !

jeanba · 20 Décembre 2016

Bien, je continue mes recherches donc!
Merci en tout cas pour ta gentillesse!
Jeanba

HONORE M.A.H.J · 20 Décembre 2016

Bonjour,

Ci-joint une contribution...

Cordialement,
HONORE

Dranreb · 20 Décembre 2016

Par exemple :

VB:

Sub JnalGeneral()
Dim XRg As Range, Wsh As Worksheet, NbPass&, NbLig&
Application.ScreenUpdating = False
Set XRg = Worksheets("Centralisation").[A2:H2]
XRg.Resize(&HFFFFF).ClearContents
For Each Wsh In ThisWorkbook.Worksheets
   If IsDate("1-" & Wsh.Name) Then If Len(Wsh.[A8].Value) > 0 Then NbPass = NbPass + 1
   Next Wsh
If NbPass = 0 Then Exit Sub
Tâche "Journal Gén.", NbPass, "opé."
For Each Wsh In ThisWorkbook.Worksheets
   If IsDate("1-" & Wsh.Name) Then
      If Len(Wsh.[A8].Value) > 0 Then
         NbLig = Wsh.Cells(Rows.Count, "A").End(xlUp).Row - 7
         If NbLig > 0 Then
             XRg.Resize(NbLig).Value = Wsh.[A8:G8].Resize(NbLig).Value
             Set XRg = XRg.Offset(NbLig): End If
         Call OùÇaEnEst: End If: End If: Next Wsh
End Sub

jeanba · 27 Décembre 2016

Bonjour Honorat,

Merci pour ta contribution.
Malheureusement, en exécutant ta macro, j'ai ce message d'erreur...

Par ailleurs, je joins à toutes fins utiles mon fichier si quelqu'un est inspiré...
Merci et Joyeux Noël!
Jeanba

Dranreb · 27 Décembre 2016

Bonjour.
Et la mienne, si facile à mettre en œuvre, avec l'exemple de programmation au poste #21, elle ne vous intéresse pas ???

jeanba · 27 Décembre 2016

Bonjour Dranreb,

Je crois que j'ai pas vu (suis allé directement au dernier message, ce qui est un peu c...).
Je regarde et te reviens d'ici peu..

Jeanba

jeanba · 27 Décembre 2016

Dranreb,

Suis pas aussi doué que tu veux bien le croire..
J'ai déjà mentionné que j'aimais bien ton chef d'oeuvre, mais de là à croire que je puis le reproduire aisément et l'insérer comme lettre à la poste dans mon projet, c'est peut-être trop..
Ecoute, peux-tu essayer avec le fichier que j'ai mis en ligne (post 22) de faire cela s'il te plaît?

Merci par avance

Jeanba

Dranreb · 27 Décembre 2016

D'accord
À +

Dranreb · 27 Décembre 2016

Voilà.
J'ai aussi enlevé les Application.ScreenUpdating = True dans CouleursLignes. Ça faisait désordre.

jeanba · 28 Décembre 2016

Bonsoir Dranreb,

Merci pour ta solution.
Je m'approche résolument de la solution.
Pour m'instantr, ça bugg
J'ai constaté que dès que je lance la macro (fichier projet final j'entends, car dans ton fichier exemple, ça roule!), il met un temps à s'afficher, puis une fois affiché, il ne fait pas le décompte...

Je regarde peut-être que j'ai pas bien repris quelque chose...
Je te tiens informé d'ici peu.

Merci
Jeanba

jeanba · 28 Décembre 2016

PS: En fait, il plante même tout le programme Excel, suis obligé de faire Fin des tâches pour l'arrêter...

Dranreb · 28 Décembre 2016

Bonjour.
Vous semblez ne jamais appeler la procédure OùÇaEnEst.
L'aspect montré par l'image n'est pas normal avec cette lisière claire autour qui laisse même entrevoir à gauche un bout d'image de la barre. L'aspect normal est celui ci :

Barre de progression

Nazim

XLDnaute Junior

Dranreb

XLDnaute Barbatruc

jeanba

XLDnaute Occasionnel

Dranreb

XLDnaute Barbatruc

jeanba

XLDnaute Occasionnel

HONORE M.A.H.J

XLDnaute Junior

Pièces jointes

Dranreb

XLDnaute Barbatruc

jeanba

XLDnaute Occasionnel

Pièces jointes

Dranreb

XLDnaute Barbatruc

jeanba

XLDnaute Occasionnel

jeanba

XLDnaute Occasionnel

Dranreb

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

Pièces jointes

jeanba

XLDnaute Occasionnel

jeanba

XLDnaute Occasionnel

Dranreb

XLDnaute Barbatruc

Discussions similaires