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

vgendron · 4 Mai 2016

Re : Barre de progression

Bonjour Nazim
pour la barre de progression, je ne sais pas vraiment, mais suis sur qu'en faisant une recherche sur ce forum tu devrais trouver des exemples

pour ta macro elle meme.. tu as certainement moyen de l'accelerer en supprimant tout un tas d'opérations inutiles et gourmandes
par exemple:
pourquoi effacer une feuille juste avant de la supprimer?

Code:

Sheets("general_report").Cells.Clear
Sheets("general_report").Delete
Application.DisplayAlerts = True

autant la supprimer direct

Code:

Sheets("general_report").Delete
Application.DisplayAlerts = True

opération inutile?

Code:

Sheets("general_report").Copy

je ne vois pas le paste associé..

ensuite, je vois beaucoup d'activate et d'aller retour entre deux feuilles

Code:

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

peut sans doute etre remplacé par

Code:

with Sheets("general_report")
   .rows(1).delete
   .rows(2).delete
...
end with

ainsi. pas besoin d'aller dans la feuille pour faire les opérations de delete
d'ailleurs, suis quasi sur que tu peux supprimer toutes les lignes souhaitées en une fois.
etc etc

mais pour bien faire et mieux se rendre compte, il faudrait que tu puisses poster ton fichier exemple. allégé.. avec juste quelques lignes
ensuite, tu pourra tester les propositions sur ton fichier complet

Nazim · 4 Mai 2016

Re : Barre de progression

Bonjour vgendron,

Merci pour ta réponse, je prendrai en considération toutes tes remarques afin d'optimiser mon code.

Pour le fichier, en jointe un fichier simplifié
il s'agit donc de sélectionner le fichier BACK.

Mon idée c'est que j'ouvre le fichier BACK, et aprés faire une barre de progression pour la copie des lignes dans les feuilles respectives.

Merci encore une fois

vgendron · 4 Mai 2016

Re : Barre de progression

Re,

sans avoir vu ton fichier et selon ce que j'ai compris de ta macro
je pense que tu peux simplifier de la sorte

Code:

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

'********************************************Retra itement******************************************


With Sheets("general_report")
    .Range("A1:A3,A5").EntireRow.Delete
    .Cells.Font.Size = 8
End With

'***********************************Distribution sur feuilles******************************************

Dim ligne
tablo = Sheets("general_report").UsedRange.Value

For l = 2 To UBound(tablo)
    With Sheets("general_report")
       'selon le contenu de la cellule (l,12) on choisit la feuille de destination
        If .Cells(l, 12) = "Done" Then Feuille = "Delivery_Backlog"
        If .Cells(l, 12) = "To Do" Or .Cells(l, 12) = "General Spec Done" Or .Cells(l, 12) = "Ready for Specification" Then Feuille = "Backlog Catalogue"
        If .Cells(l, 12) = "USED IN PRODUCTION" Or .Cells(l, 12) = "In Progress" Or .Cells(l, 12) = "Peer review" Or .Cells(l, 12) = "Dev - In Progress" Or .Cells(l, 12) = "Prioritized" Or .Cells(l, 12) = "PreUAT" Or .Cells(l, 12) = "SIT" Then Feuill = "Used In Prod"
         'attention, cas ou la cellule est vide ou contient autre chose n'est pas traité: voir pour passer avec un select case
        'on copie la ligne dans la feuille de destination
        ligne = .Rows(l)
        With Sheets(Feuille)
            .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = ligne
        End With
    End With
Next l

Sheets("Delivery_Backlog").Cells.Font.Size = 8
Sheets("Backlog Catalogue").Cells.Font.Size = 8
Sheets("Used In Prod").Cells.Font.Size = 8
End Sub

Nazim · 4 Mai 2016

Re : Barre de progression

Re,
Merci beaucoup,
j’espère maintenant trouver une solution pour la barre de progression

Merci

vgendron · 4 Mai 2016

Re : Barre de progression

Re

avec quelques modifs et commentaires en plus

Code:

Sub ImportData()

Application.DisplayAlerts = False

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 '?? je n'ai pas bien saisi sur quel fichier on travaille..



'********************************************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 'sinon on ferme le classeur dans lequel on souhaitait travailler.???

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


With Sheets("general_report")
    .Range("A1:A3,A5").EntireRow.Delete  'est on sur de devoir supprimer la ligne 5 ?
    .Cells.Font.Size = 8
End With

'***********************************Distribution sur feuilles******************************************

Dim ligne
tablo = Sheets("general_report").UsedRange.Value

For l = 2 To UBound(tablo)
    With Sheets("general_report")
       'selon le contenu de la cellule (l,12) on choisit la feuille de destination
        If .Cells(l, 12) = "Done" Then Feuille = "Delivery_Backlog"
        If .Cells(l, 12) = "To Do" Or .Cells(l, 12) = "General Spec Done" Or .Cells(l, 12) = "Ready for Specification" Then Feuille = "Backlog Catalogue"
        If .Cells(l, 12) = "USED IN PRODUCTION" Or .Cells(l, 12) = "In Progress" Or .Cells(l, 12) = "Peer review" Or .Cells(l, 12) = "Dev - In Progress" Or .Cells(l, 12) = "Prioritized" Or .Cells(l, 12) = "PreUAT" Or .Cells(l, 12) = "SIT" Then Feuille = "Used In Prod"
         'attention, cas ou la cellule est vide ou contient autre chose n'est pas traité: voir pour passer avec un select case
        'on copie la ligne dans la feuille de destination
        .Rows(l).Copy Destination:=Sheets(Feuille).Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
       
    End With
Next l

Sheets("Delivery_Backlog").Cells.Font.Size = 8
Sheets("Backlog Catalogue").Cells.Font.Size = 8
Sheets("Used In Prod").Cells.Font.Size = 8
End Sub

Nazim · 4 Mai 2016

Re : Barre de progression

Re,

Merci encore une fois pour ce code optimisé mais il y'a une erreur d’exécution au niveau de la ligne suivante que je n'arrive pas a comprendre: " .Rows(l).Copy Destination:=Sheets(Feuille).Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)"

Merci

Des idées pour la progress bar ?

vgendron · 4 Mai 2016

Re : Barre de progression

Re

Pour le problème: il s'agissait d'une erreur sur le nom de la feuille: avec ou sans Espace (touche 8)

ce qui donne

Code:

Sub ImportData()

Application.DisplayAlerts = False
'initialisation en supprimant l'onglet
Sheets("general_report").Delete
Application.DisplayAlerts = True

Dim wBase As Workbook, wOuvert As Workbook, WS As Worksheet
Set wBase = ThisWorkbook
'ouverture du fichier source
If Not Application.Dialogs(xlDialogOpen).Show Then Exit Sub
Set wOuvert = ActiveWorkbook
'recopie des onglets dans le fichier de travail base
For Each WS In wOuvert.Worksheets
    WS.Copy After:=wBase.Worksheets(wBase.Worksheets.Count)
Next WS
wOuvert.Close 'fermuture du fichier source


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

LeNom = strDate & ".xls"
ActiveWorkbook.SaveAs LePath2 & "Data " & LeNom

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


With Sheets("general_report")
    .Range("A1:A4").EntireRow.Delete  'suppression des lignes d'info avant la ligne d'entete
    .Cells.Font.Size = 8
End With

'***********************************Distribution sur feuilles******************************************

Dim ligne
tablo = Sheets("general_report").UsedRange.Value

For l = 2 To UBound(tablo)
    With Sheets("general_report")
       'selon le contenu de la cellule (l,12) on choisit la feuille de destination
        If .Cells(l, 12) = "Done" Then Feuille = "Delivery Backlog"
        If .Cells(l, 12) = "To Do" Or .Cells(l, 12) = "General Spec Done" Or .Cells(l, 12) = "Ready for Specification" Then Feuille = "Backlog Catalogue"
        If .Cells(l, 12) = "USED IN PRODUCTION" Or .Cells(l, 12) = "In Progress" Or .Cells(l, 12) = "Peer review" Or .Cells(l, 12) = "Dev - In Progress" Or .Cells(l, 12) = "Prioritized" Or .Cells(l, 12) = "PreUAT" Or .Cells(l, 12) = "SIT" Then Feuille = "Used In Prod"
         'attention, cas ou la cellule est vide ou contient autre chose n'est pas traité: voir pour passer avec un select case
        'on copie la ligne dans la feuille de destination
        .Rows(l).Copy Destination:=Sheets(Feuille).Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
    End With
Next l

Sheets("Delivery Backlog").Cells.Font.Size = 8
Sheets("Backlog Catalogue").Cells.Font.Size = 8
Sheets("Used In Prod").Cells.Font.Size = 8
End Sub

pour la barre de progression...je n'ai pas regardé: as tu fait une recherche sur le forum?

Nazim · 4 Mai 2016

Re : Barre de progression

Hello vgendron
Merci beaucoup pour ton code c'est tres optimisé ! le temps d'execution est passé de 1 minutes a une dizaine de seconde ce qui est énorme ! Merci beaucoup

Pour la progress Bar, j'ai regardé, j'ai trouvé quelques idées mais je n'arrive pas à l'adapter a mon code :/

Merci

joedu31 · 4 Mai 2016

Re : Barre de progression

Salut,

Un site qui pourrait t'aider
Barre de progression

Joe

Nazim · 9 Mai 2016

Re : Barre de progression

tdffffffffffffff

Dranreb · 9 Mai 2016

Re : Barre de progression

Bonsoir.
Sinon il y a toujours la mienne qui est assez facile à mettre en œuvre.

Nazim · 10 Mai 2016

Re : Barre de progression

Bonjour,

Merci pour ta réponse Dranreb,

Regards,
Nazim

Nazim · 6 Juin 2016

Re : Barre de progression

Bonjour
ci-joint le resultat final,
cordialement,

Nazim

jeanba · 20 Décembre 2016

Bonjour le Forum,

Je faisais des recherches sur ce sujet lorsque je suis tombé sur cette discussion.

Les éléments y sont très intéressants (cf derniers posts de Dranreb avec estimation du temps restant et tout! Wahoo!)
En revanche, j'y vois chaque fois une macro qui remplit des cellules jusqu'à la limite fixée dans l'algo.
or, mon problème est que j'ai une macro très longue et je souhaite afficher le message "traitement en cours, veuillez patienter..."
+ une barre de progression de l'exécution de ma macro.

J'ai tenté des tas de trucs, et j'ai trouvé le code ci-joint sur le site de Microsoft (code en anglais donc).
Je joins ma macro pour vous demander où insérer quoi pour que la barre de progression ci-jointe (ou encore celle de Dranreb que j'ai beaucoup aimée) s'affiche pendant l'exécution de ma macro...

En vous en remerciant par avance!

ATTENTION!
La Macro Microsoft dans le fichier ci-joint fonctionne très bien. Mais, je veux qu'au lieu qu'elle compte le temps de progression pendant qu'elle écrit dans les cellules de la feuille, que ce soit plutôt le temps d'exécution de ma macro.
Donc, bien vouloir l'aménager s'il vous plait pour qu'elle n'écrive nulle part.

VB:

Sub JnalGeneral()
Dim wsh As Worksheet, derlig&, xrg As Range
Application.ScreenUpdating = False
With Sheets("Centralisation")
    DeverrouillerFeuille
End With
Worksheets("Centralisation").Range("A2:H" & Rows.Count).ClearContents
Sheets("Centralisation").Visible = True
    For Each wsh In ThisWorkbook.Worksheets
        If IsDate("1-" & wsh.Name) Then
            If Len(wsh.Range("A8")) > 0 Then
                    With Worksheets("Centralisation")
                           DeverrouillerFeuille
                           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:G" & derlig).Copy
                               xrg.PasteSpecial xlPasteValues
                               xrg.Offset(, -1).Resize(wsh.Range("A8:G" & derlig).Rows.Count) = Month("1-" & wsh.Name)
                           End If
                            CouleurLignes
                            ActiveSheet.PageSetup.LeftHeader = Range("parametres!B1").Value & " " & Range("parametres!B2").Value          'Texte section gauche = Nom de la Société client
  '                          ImprimerFeuilleActive
  '                          .Visible = False
                    End With
            End If
        End If
    Next wsh
'    Sheets("accueil").Visible = True
End Sub

Barre de progression

Nazim

XLDnaute Junior

vgendron

XLDnaute Barbatruc

Nazim

XLDnaute Junior

Pièces jointes

vgendron

XLDnaute Barbatruc

Nazim

XLDnaute Junior

vgendron

XLDnaute Barbatruc

Nazim

XLDnaute Junior

vgendron

XLDnaute Barbatruc

Nazim

XLDnaute Junior

joedu31

XLDnaute Nouveau

Nazim

XLDnaute Junior

Dranreb

XLDnaute Barbatruc

Pièces jointes

Nazim

XLDnaute Junior

Nazim

XLDnaute Junior

jeanba

XLDnaute Occasionnel

Pièces jointes

Discussions similaires