Barre de progression

N

Nazim

XLDnaute Junior
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
 
Trier par date Trier par votes
vgendron

vgendron

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
N

Nazim

XLDnaute Junior
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
 

Pièces jointes

  • DashBoard.zip
    74.9 KB · Affichages: 48
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
N

Nazim

XLDnaute Junior
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 ?
 
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
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?
 
Vote positif 0 Vote négatif
N

Nazim

XLDnaute Junior
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 :)
 
Vote positif 0 Vote négatif
jeanba

jeanba

XLDnaute Occasionnel
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
 

Pièces jointes

  • Barre de progression en panne.xlsm
    17.2 KB · Affichages: 50
Vote positif 0 Vote négatif

Discussions similaires

Chaton77
  • Résolu(e)
Microsoft 365 Vba : Transférer des données d'un tableau dans un autre fichier
Réponses
7
Affichages
352
Chaton77
Chaton77
Nicolas JACQUIN
  • Question
XL 2021 Création et adaptation barre de progression
2 3
Réponses
44
Affichages
1 K
Tartine
T
B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
489
Compte Supprimé 979
C
ph.vanne
  • Question
Autres fenêtre "Publication"
Réponses
10
Affichages
338
ph.vanne
ph.vanne
G
  • Résolu(e)
XL 2010 Obliger la validation d'un bouton d'option.
Réponses
8
Affichages
290
gillesda
G
cathodique
  • Résolu(e)
XL 2010 Mauvaise utilisation de la fonction InStr
Réponses
11
Affichages
582
jurassic pork
jurassic pork
B
  • Question
Microsoft 365 [RESOLU] Supprimer Ligne rapidement et avec plusieurs conditions
Réponses
5
Affichages
316
BENAM69
B
C
  • Résolu(e)
XL 2021 Remplir données devis en vba avec descriptions/quantités/PUs alignés
2
Réponses
18
Affichages
985
Phil69970
Phil69970
A
  • Question
Insérer un copier / coller
Réponses
0
Affichages
271
aziz
A
N
  • Résolu(e)
Microsoft 365 Macro copier/coller entre deux tableaux structurés
3 4 5
Réponses
66
Affichages
1 K
job75
job75

Membres actuellement en ligne

10 membres et 111 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 653
Messages
2 111 592
Membres
111 208
dernier inscrit
estalavista