Bar de progression

[kyasteph]

Bonjour,

j'ai une macro qui fait appel à une userform contenant une barre de progression.
Jusque la aucun probleme,ma macro marche comme je le souhaite;de meme que le userform s'affiche au moment voulu et disparait à la fin de la macro,impeccable.
Cependant pendant l'exécution de ma macro ma barre de progression(à l'interieur du usf) se remplit automatiquement or je souhaite qu'elle progresse en fonction de l'exécution de la macro.
C'est la que je suis bloqué,je ne sais vraiment comment y arriver,je penche la dessus depuis plusieurs jours maintenant.

Merci de m'aider s'il vous plait

voici mon code

Option Explicit
Dim ProgressIndicator As UserForm1

Sub Rassembler()
'Déclarations, opérations préliminaires...
    Dim Counter As Integer
    Dim RowMax As Integer, ColMax As Integer
    Dim r As Integer, c As Integer
    Dim PctDone As Single
Application.Calculation = xlManual
FiltrerDateRassembler
Application.ScreenUpdating = False
'   Crée une copie du forme dans une variable
    Set ProgressIndicator = New UserForm1
    
'   Affiche Barreprogression dans état modeless
    ProgressIndicator.Show vbModeless
    If TypeName(ActiveSheet) <> "Worksheet" Then
        Unload ProgressIndicator
        Exit Sub
    End If
    Counter = 1
    RowMax = 650
    ColMax = 50
    For r = 1 To RowMax
        For c = 1 To ColMax
            Counter = Counter + 1
        Next c
        PctDone = Counter / (RowMax * ColMax)
        Call UpdateProgress(PctDone)
    Next r
'Feuilles à traiter
Const cF = "JAL_AN/Gestion_Créancier/Gestion_Caisse/Gestion_Banque/JAL_OD"

'Ligne des en-têtes de chaque feuille à traiter
Const cFligneDebut = "11/10/9/11/11"

'Noms des champs à copier
Const cChamps = "N°compte gle/Mois/Date/Libellé/Débit/Crédit"

'Le & remplace ' as long', le $ remplace ' as string'
Dim i&, j&, DebLig&, Finlig&, NumCol, rep&
Dim F, FligneDebut, Champs, NomF$, Sh As Worksheet
Dim rgTitre As Range, rgAcopier As Range, rgBase As Range, rgIci As Range

'Split transforme une chaine de caractères en un tableau de mots à une dimension
'le séparateur de mots est le caractère /
'indice inf du tableau résultant est toujours 0 (jamais 1)
F = Split(cF, "/")                        'tableau des noms des feuilles à traiter
FligneDebut = Split(cFligneDebut, "/")    'Tableau des n° ligne des en-têtes
Champs = Split(cChamps, "/")              'Tableau des champs à copier

'effacer précédent traitement
Sheets("TCD").Activate
ActiveSheet.Unprotect "MDP"
Range("A2:H" & Rows.Count).Clear
Application.ScreenUpdating = False

'lbound(tablo,2) retourne le plus petit indice de la deuxième dimension de tablo
'ubound(tablo,1) retourne le plus grand indice de la première dimension de tablo
'ex: si DIM tablo( 0 to 4, 10 to 29) alors
'lbound(tablo,1)=0, ubound(tablo,1)=4, lbound(tablo,2)=10, ubound(tablo,2)=29
'si on traite la première dimension du tableau, on peut omettre ,1
'lbound(tablo)=0, ubound(tablo)=4
'Quand on ne connait pas à l'avance les bornes des indices d'un tableau, c'est pratique.
'Quand on ne sait plus si SPLIT donne des tableaux à base 0 ou 1, lbound et ubound
'permette de contourner cet oubli.

For i = LBound(F) To UBound(F)
  'Boucle sur les noms de feuilles à traiter
  NomF = F(i): Set Sh = Sheets(NomF)
'on ôte le filtres automatique
  If Sh.AutoFilterMode Then Sh.AutoFilterMode = False
  'n° ligne des en-têtes
  DebLig = FligneDebut(i)
  'recherche de la dernière ligne à copier
  Finlig = Sh.Range("b" & Rows.Count).End(xlUp).Row
  If Finlig > DebLig Then
    'il y a effectivement des données à copier
    'Définir la cellule où copier les champs - on se base sur la colonne C des dates
    Set rgBase = Range("c" & Rows.Count).End(xlUp).Offset(1, -2)
    'définir la zone d'en-tête
    Set rgTitre = Sh.Range(Sh.Cells(DebLig, "a"), Sh.Cells(DebLig, _
        "a").End(xlToRight))
    'rétablir le filtre mais en affichant tout
    Sh.Unprotect "MDP"
    rgTitre.AutoFilter
    For j = LBound(Champs) To UBound(Champs)
      'boucle sur les champs à copier
      'on error resume next permet de continuer l'exécution si le champ cherché
      'ne se trouve pas dans la ligne des titres
      NumCol = 0
      'rechercher le numéro de colonne du champ à copier dans la ligne d'en-têtes
      On Error Resume Next
      NumCol = Application.WorksheetFunction.Match(Champs(j), rgTitre, 0)
      If NumCol > 0 Then
        'le champ a été trouvé (donc son numéro), on copie les données
        Set rgAcopier = Sh.Range(Sh.Cells(DebLig + 1, NumCol), Sh.Cells(Finlig, _
            NumCol))
        Set rgIci = rgBase.Offset(, j)
        rgAcopier.Copy
        rgIci.PasteSpecial xlPasteValues
        rgIci.PasteSpecial xlPasteFormats
      
      ElseIf NomF = "Gestion_Créancier" And Champs(j) = "Débit" Then
        ' le champ à copier est inconnu
        '==> VERRUE 1 : feuille = "Gestion_Créancier" et Champs = "Débit"
        'chercher le champ "Mtant TTC" (on suppose qu'il existe toujours)
        'pas de gestion du cas où il serait inexistant!
        NumCol = Application.WorksheetFunction.Match("Mtant TTC", rgTitre, 0)
        Set rgAcopier = Sh.Range(Sh.Cells(DebLig + 1, NumCol), Sh.Cells(Finlig, _
            NumCol))
        Set rgIci = rgBase.Offset(, j)
        rgAcopier.Copy
        rgIci.PasteSpecial xlPasteValues
        rgIci.PasteSpecial xlPasteFormats
        'chercher le champ "Dt TVA" (on suppose qu'il existe toujours)
        'pas de gestion du cas où il serait inexistant!
        NumCol = Application.WorksheetFunction.Match("Dt TVA", rgTitre, 0)
        Set rgAcopier = Sh.Range(Sh.Cells(DebLig + 1, NumCol), Sh.Cells(Finlig, _
            NumCol))
        Set rgIci = rgBase.Offset(, j)
        rgAcopier.Copy
        rgIci.PasteSpecial Paste:=xlPasteValues, _
            Operation:=xlPasteSpecialOperationSubtract
        
      ElseIf NomF = "Gestion_Créancier" And Champs(j) = "Crédit" Then
        '' le champ à copier est inconnu
        '==> VERRUE 2 : feuille = "Gestion_Créancier" et Champs = "Crédit"
        'chercher le champ "Mtant TTC" (on suppose qu'il existe toujours)
        'pas de gestion du cas où il serait inexistant!
        'on ne fait rien càd on laisse la cellule à vide
      
      Else
        'le champ à recopier n'existe pas et ne fait pas l'objet d'une VERRUE
        'on y met le texte en rouge <Champs> PAS TROUVÉ
        Set rgIci = rgBase.Offset(, j).Resize(Finlig - DebLig)
        rgIci.Value = "Champ <" & Champs(j) & "> PAS TROUVÉ"
        rgIci.Font.Bold = True
        rgIci.Font.Color = RGB(255, 0, 0)
      End If
    Next j
    Set rgIci = rgBase.Offset(, j).Resize(Finlig - DebLig)
    rgIci = NomF
  End If
Next i

Range("a1").CurrentRegionShrinkToFit = False
Range("a1").CurrentRegion.Borders.LineStyle = xlContinuous
Range("a1").CurrentRegion.FormatConditions.Delete
Range("a1").Resize(, UBound(Champs) - LBound(Champs) + 1).Value = Champs
Range("a1").Offset(, UBound(Champs) - LBound(Champs) + 1) = "Code JAL"
'déplacement de la dernière colonne de TCD (Code JAL) avant la colonne B
Columns(UBound(Champs) - LBound(Champs) + 2).Cut
Columns("B:B").Insert Shift:=xlToRight
Range("a1").CurrentRegion.EntireColumn.AutoFit
Range("a1").CurrentRegion.Rows(1).Interior.Color = RGB(200, 200, 200)

'VERRUE:  Suppression des lignes où N°compte gle est à vide
Set rgAcopier = Nothing
On Error Resume Next
Set rgAcopier = _
    Range("a1").CurrentRegion.Offset(1).Columns(1).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rgAcopier Is Nothing Then
  'il y a des cellules vide, on supprime leur ligne
  rgAcopier.EntireRow.Delete
End If

'Création COLONNE Intitulé
    Range("H1") = "Intitulé"
    Range("H2").Select
    ActiveCell.FormulaR1C1 = "=IF(ISBLANK(RC[-7]),"""",CONCATENATE(RC[-7],"" - "",(LOOKUP(RC[-7],COMPTES,INTITULE_COMPTES))))"
    Selection.Copy
    Range("H3:H" & ActiveSheet.UsedRange.Rows.Count).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("H1").CurrentRegion.EntireColumn.AutoFit
    
'RANGER par N° de compte du plus petit au plus grand
Range("A1:J1").Select
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("TCD").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("TCD").AutoFilter.Sort.SortFields.Add Key:=Range( _
        "D1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("TCD").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
'Création COLONNE Solde Débit.
    Range("I1") = "Solde Débit."
    Range("I2").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(SUMPRODUCT((R2C[-8]:RC[-8]=RC[-8])*(R2C[-3]:RC[-3]-R2C[-2]:RC[-2]))>0,SUMPRODUCT((R2C[-8]:RC[-8]=RC[-8])*(R2C[-3]:RC[-3]-R2C[-2]:RC[-2])),0)"
    Selection.Copy
    Range("I2:I" & ActiveSheet.UsedRange.Rows.Count).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("I1").CurrentRegion.EntireColumn.AutoFit
    
'Création COLONNE Solde Crédit.
    Range("J1") = "Solde Crédit."
    Range("J2").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(SUMPRODUCT((R2C[-9]:RC[-9]=RC[-9])*(R2C[-4]:RC[-4]-R2C[-3]:RC[-3]))<0,SUMPRODUCT((R2C[-9]:RC[-9]=RC[-9])*(R2C[-3]:RC[-3]-R2C[-4]:RC[-4])),0)"
    Selection.Copy
    Range("J2:J" & ActiveSheet.UsedRange.Rows.Count).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("J1").CurrentRegion.EntireColumn.AutoFit
    
    Range("A1:J1").Select
    Selection.AutoFilter

Range("a1").Select
Application.ScreenUpdating = True
ActiveSheet.Protect "MDP"
For i = LBound(F) To UBound(F)
  'Boucle sur les noms de feuilles à traiter
  NomF = F(i): Set Sh = Sheets(NomF)
  'On reprotege les feuilles déprotégées
Sh.Protect "MDP"
Next
    Unload ProgressIndicator
    Set ProgressIndicator = Nothing
Sheets("Grand_Livre").Select
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub

Sub UpdateProgress(pct)
    With ProgressIndicator
        .FrameProgress.Caption = Format(pct, "0%")
        .LabelProgress.Width = pct * (.FrameProgress _
           .Width - 10)
    End With
'   L'instruction DoEvents est responsable fde la mise à jour de l'Userform
    DoEvents
End Sub

 

[Roland_M]

Re : Bar de progression

bonsoir à tous,

excuses moi kyasteph, mais ta barre ne sert strictement à rien dans le cas présent !
elle se rempli puis le code s'exécute ensuite !? c'est tout simplement incohérent et inutile !

une barre doit être en relation avec le temps réel de l'exécution du code !
exemple, tu charges 10 fichiers la barre doit se remplir d'un dixième à chaque fichier chargé pour être à 100% au dernier.

EDIT:

@ROGER2327, à ta santé !

 

[Zdz16]

Re : Bar de progression

Bonjour KyaSteph;

Je viens de déposer une classe pour une barre de progression ici https://www.excel-downloads.com/threads/ouverture-usf-et-methode-show.219715/

peut-être cela pourrait te convenir.

Cordialement

 

[Dranreb]

Re : Bar de progression

Bonjour.

… Et je viens d'y ajouter ma propre solution standard juste derrière.

 

[Paf]

Re : Bar de progression

Bonjour à tous

a priori ce n'est pas la progressbar en elle même qui pose soucis à kyasteph mais comment lui faire afficher la progression de sa macro.
Comme je le signalais au post #3 et comme le souligne Roland_M au post #16 il faut faire progresser la barre en fonction de l'avancement du code.

Par exemple

Sub Rassembler()
....
For i = LBound(F) To UBound(F)
  'Boucle sur les noms de feuilles à traiter

   ......'code
  appel de la mise à jour progress bar progression  1/UBound(F) ' en fin de boucle on aura une progression de 100%
Next i

'Traitement  COLONNES et données
'Création COLONNE Intitulé
..... code
appel de la mise à jour progress bar progression  25% ' 

'RANGER par N° de compte du plus petit au plus grand
..... code
appel de la mise à jour progress bar progression  25% ' 

'Création COLONNE Solde Débit.
..... code
appel de la mise à jour progress bar progression  25% ' 

'Création COLONNE Solde Crédit.
..... code
appel de la mise à jour progress bar progression  25% ' 

en fin de Traitement  COLONNES et données on aura une progression de 100%

  'Boucle sur les noms de feuilles à traiter protection des feuilles
For i = LBound(F) To UBound(F)
  ... code
appel de la mise à jour progress bar progression  de 1/UBound(F) '
Next

Pas sûr que le découpage soit judicieux au niveau temps d'exécution, mais c'est pour présenter le principe pour kyasteph, s'il suit toujours le fil

A+

 

[Dranreb]

Re : Bar de progression

Pour cela il faut se débrouiller d'une façon ou d'une autre pour connaitre le nombre d'appel à OùÇaEnEst qu'on aura à faire, quitte à faire presque 2 fois le travail, avec uniquement d'abord le plus rapide sans la barre (en profiter pour préparer la seconde phase dans des tableaux en y retenant ce qu'on a trouvé)

Dans un classeur de recherche de bibliothèques et d'objets, par exemple je fais la chasse aux infos TypeLib dans tous les fichiers DLL, OCX etc. d'un certain nombre de différents dossiers. C'est un peu long. Alors je n'ai d'abord fait que les Dir, les ai empilés dans un tableau avec leur chemin, dont le nombre d'éléments me donne le 2ième paramètre à passer à Tâche.

 

[Zdz16]

Re : Bar de progression

Bonjour à Tous;

La barre de progression que j'ai proposé m'est utiles telle quelle. Mais si vous voulez l'adapter c'est possible.

Le point clé se trouve dans la méthode 'Display' de la classe, vous remarquerez que l'appel à cette méthode se fait à l'intérieur de la boucle de traitement, donc il est possible de la modifier pour tenir compte d'un argument avec votre propre pourcentage de progression.

L'autre solution possible est de gérer deux barres de progression. Une pour l'avancement des macros et une pour le traitement des macros (Ainsi si la première est à 100% cela signifie que toutes les macros ont été exécutées, tandis que la deuxième affiche la progression d'une macro ou un traitement particulier).

Bon, se sont des idées, il faut voir la réalisation.

Cordialement

 

[Chubby]

Re : Bar de progression

Mon problème de barre de progression ne semble plus exister... ouf

 

[Paf]

Re : Bar de progression

Bonsoir

Si le sujet de cette discussion est bien Bar de progression ce n'est pas pour autant qu'il s'agit de traiter tous les soucis de Barre de progression !

Ouvrez plutôt une nouvelle discussion.

Cordialement