Barre de progression Macro

Question

Bonjour

Je me permets de sollicité l'aide de la communauté concernant la mise en place d'une barre de progression qui met en évidence l'avancement de traitement d'une macro.
J'ai crée une UserFrom1 et son code est le suivantSub afficher() Me.Show 0 End Sub Sub TriAutomatique(taux As Integer) Barreprogression.Width = (taux * textePourcentage.Width) / 100 textePourcentage = taux & "%" If taux = 100 Then Unload Me End If DoEvents End Sub

Néanmoins je n'arrive pas à la rattaché à l'exécution de la macro ci-dessous : Sub TriAutomatique() 'Désactivation mise à jour écran Application.ScreenUpdating = False 'Désactivation événement Application.EnableEvents = False 'Déclaration des variables Dim Data As String Dim Nombre As Integer Dim Nb As Integer Dim Index As Integer Dim IndexNB As Integer Dim RecapLignes As Integer Dim Cellule1 As Integer Dim Cellule2 As Integer Dim NbLignes As Integer Dim xRg As Range Dim LoopLignes As Integer Dim LoopDET As Integer Dim NumDET As Integer 'Ajout lignes "DET" NumDET = 1 Do While NumDET <= 20 LoopDET = 1 Sheets("DET" & NumDET).Select Do While LoopDET < 21 Range("60:60").Copy Range("62:62").Insert Range("61:61").Copy Range("63:63").Insert LoopDET = LoopDET + 1 Loop 'Range("B67:B106").SpecialCells(xlCellTypeBlanks).EntireRow.Delete NumDET = NumDET + 1 Loop 'Ajout lignes "Récap" Sheets("Récap").Select LoopLignes = 0 Do While LoopLignes < 30 Sheets("Récap").Select Range("41:41").Copy Range("43:43").Insert Range("42:42").Copy Range("44:44").Insert LoopLignes = LoopLignes + 1 Loop 'Remise par défaut Index = 1 IndexNB = 0 Cellule2 = 21 RecapLignes = 0 'Selection feuille Extraction Comptable Sheets("Extraction Comptable").Select 'Duplique la feuille Extraction Comptable et renomme en Liste Worksheets("Extraction Comptable").Copy after:=Worksheets("Extraction Comptable") ActiveSheet.Name = "Liste" 'Nombre de ligne NbLignes = Application.WorksheetFunction.CountA(Worksheets("Liste").Range("C1:C5000")) 'Nombre de facture Nb = Application.WorksheetFunction.CountA(Sheets("Liste").Range("C2:C" & NbLignes)) 'essayer de changer C2:C50 'MsgBox (Nb) 'Boucle jusqu'à l'index soit <= Nb Do While IndexNB < Nb 'Réccuperation de l'intitulé du tiers Data = cells(2, 3) 'MsgBox (Data) 'Détermination du nombre de facture du fournisseur Nombre = WorksheetFunction.CountIf(Worksheets("Liste").Range("C2:C" & NbLignes), Data) 'essayer de changer C2:C50 'MsgBox (Nombre) 'Remise par défaut Cellule1 = 17 On Error Resume Next If Nombre > 1 Then Do While Nombre >= 1 Set xRg = Range("C2:C" & NbLignes).Find(Data, , xlValues, xlWhole, , , True) xRg.Select xIndex = Application.ActiveCell.Row Range(cells(xIndex, 1), cells(xIndex, 7)).Copy Sheets("DET" & Index).Range("B" & Cellule1).PasteSpecial Paste:=xlPasteValues Sheets("Liste").Range(cells(xIndex, 1), cells(xIndex, 7)).Delete Nombre = Nombre - 1 Cellule1 = Cellule1 + 1 IndexNB = IndexNB + 1 Loop Index = Index + 1 Else: If RecapLignes > 35 Then 'insert lignes Range("56:56" & "57:57").Copy Range("58:58").Insert Else 'Ne rien faire End If Set xRg = Range("C2:C" & NbLignes).Find(Data, , xlValues, xlWhole, , , True) xRg.Select xIndex = Application.ActiveCell.Row Range(cells(xIndex, 1), cells(xIndex, 7)).Copy Sheets("Récap").Range("B" & Cellule2).PasteSpecial Paste:=xlPasteValues Sheets("Liste").Range(cells(xIndex, 1), cells(xIndex, 7)).Delete Cellule2 = Cellule2 + 1 IndexNB = IndexNB + 1 RecapLignes = RecapLignes + 1 End If Loop 'Suppression cellule vide "Récap" Sheets("Récap").Select Range("B44:B103").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'Suppression cellule vide "DET" NumDET = 1 Do While NumDET <= 20 Sheets("DET" & NumDET).Select Range("B67:B106").SpecialCells(xlCellTypeBlanks).EntireRow.Delete NumDET = NumDET + 1 Loop 'Désactivation des alertes Application.DisplayAlerts = False Sheets("Liste").Delete Sheets("Récap").Select 'Activation mise à jour écran Application.ScreenUpdating = True 'Activation événement Application.EnableEvents = True MsgBox ("Tri Effectué") End Sub Sub TriAutomatiqueMiseAJour() 'Désactivation mise à jour écran Application.ScreenUpdating = False 'Désactivation événement Application.EnableEvents = False 'Déclaration des variables Dim Data As String Dim Nombre As Integer Dim Nb As Integer Dim Index As Integer Dim IndexNB As Integer Dim RecapLignes As Integer Dim Cellule1 As Integer Dim Cellule2 As Integer Dim NbLignes As Integer Dim xRg As Range Dim LoopLignes As Integer Dim LoopDET As Integer Dim NumDET As Integer 'Supression Range("B21:H43").Select Selection.ClearContents Range("F14").Select Selection.ClearContents Sheets(Array("DET1", "DET2", "DET3", "DET4", "DET5", "DET6", "DET7", "DET8", "DET9", _ "DET10", "DET11", "DET12", "DET13", "DET14", "DET15", "DET16", "DET17", "DET18", "DET19" _ , "DET20")).Select Sheets("DET1").Activate Range("F34,B17:H65").Select Range("B17").Activate Selection.ClearContents Sheets("Récap").Select Range("D30").Select ActiveWindow.SmallScroll Down:=-12 Do While Range("B44") <> "Factures en lot : (+1)" Range("B44").EntireRow.Delete Loop NumDET = 1 Do While NumDET <= 20 Sheets("DET" & NumDET).Select Do While Range("B67") <> "Total" Range("B67").EntireRow.Delete Loop NumDET = NumDET + 1 Loop Sheets("Récap").Select 'Ajout lignes "DET" NumDET = 1 Do While NumDET <= 20 LoopDET = 1 Sheets("DET" & NumDET).Select Do While LoopDET < 21 Range("60:60").Copy Range("62:62").Insert Range("61:61").Copy Range("63:63").Insert LoopDET = LoopDET + 1 Loop 'Range("B67:B106").SpecialCells(xlCellTypeBlanks).EntireRow.Delete NumDET = NumDET + 1 Loop 'Ajout lignes "Récap" Sheets("Récap").Select LoopLignes = 0 Do While LoopLignes < 30 Sheets("Récap").Select Range("41:41").Copy Range("43:43").Insert Range("42:42").Copy Range("44:44").Insert LoopLignes = LoopLignes + 1 Loop 'Remise par défaut Index = 1 IndexNB = 0 Cellule2 = 21 RecapLignes = 0 'Selection feuille Extraction Comptable Sheets("Extraction Comptable").Select 'Duplique la feuille Extraction Comptable et renomme en Liste Worksheets("Extraction Comptable").Copy after:=Worksheets("Extraction Comptable") ActiveSheet.Name = "Liste" 'Nombre de ligne NbLignes = Application.WorksheetFunction.CountA(Worksheets("Liste").Range("C1:C5000")) 'Nombre de facture Nb = Application.WorksheetFunction.CountA(Sheets("Liste").Range("C2:C" & NbLignes)) 'essayer de changer C2:C50 'MsgBox (Nb) 'Boucle jusqu'à l'index soit <= Nb Do While IndexNB < Nb 'Réccuperation de l'intitulé du tiers Data = cells(2, 3) 'MsgBox (Data) 'Détermination du nombre de facture du fournisseur Nombre = WorksheetFunction.CountIf(Worksheets("Liste").Range("C2:C" & NbLignes), Data) 'essayer de changer C2:C50 'MsgBox (Nombre) 'Remise par défaut Cellule1 = 17 On Error Resume Next If Nombre > 1 Then Do While Nombre >= 1 Set xRg = Range("C2:C" & NbLignes).Find(Data, , xlValues, xlWhole, , , True) xRg.Select xIndex = Application.ActiveCell.Row Range(cells(xIndex, 1), cells(xIndex, 7)).Copy Sheets("DET" & Index).Range("B" & Cellule1).PasteSpecial Paste:=xlPasteValues Sheets("Liste").Range(cells(xIndex, 1), cells(xIndex, 7)).Delete Nombre = Nombre - 1 Cellule1 = Cellule1 + 1 IndexNB = IndexNB + 1 Loop Index = Index + 1 Else: If RecapLignes > 35 Then 'insert lignes Range("56:56" & "57:57").Copy Range("58:58").Insert Else 'Ne rien faire End If Set xRg = Range("C2:C" & NbLignes).Find(Data, , xlValues, xlWhole, , , True) xRg.Select xIndex = Application.ActiveCell.Row Range(cells(xIndex, 1), cells(xIndex, 7)).Copy Sheets("Récap").Range("B" & Cellule2).PasteSpecial Paste:=xlPasteValues Sheets("Liste").Range(cells(xIndex, 1), cells(xIndex, 7)).Delete Cellule2 = Cellule2 + 1 IndexNB = IndexNB + 1 RecapLignes = RecapLignes + 1 End If Loop 'Suppression cellule vide "Récap" Sheets("Récap").Select Range("B44:B103").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'Suppression cellule vide "DET" NumDET = 1 Do While NumDET <= 20 Sheets("DET" & NumDET).Select Range("B67:B106").SpecialCells(xlCellTypeBlanks).EntireRow.Delete NumDET = NumDET + 1 Loop 'Désactivation des alertes Application.DisplayAlerts = False Sheets("Liste").Delete Sheets("Récap").Select 'Activation mise à jour écran Application.ScreenUpdating = True 'Activation événement Application.EnableEvents = True MsgBox ("Mise A Jour Effectué") End Sub

Pourriez vous m'indiquer ce qui est nécessaire de réaliser pour faire apparaitre la barre de progression ?

Je vous remercie par avance pour votre aide

h2so4 · Answer

Peux-tu revoir ta demande et la mettre en forme correctement ? Utilise le bouton &lt;/&gt; pour mettre du code, pas le bouton &#91;&#93; ...

h2so4 · Answer

Apparemment, ta copie de macro n'est pas correcte, toutes les séparations de ligne ont disparu. Ce que tu as mis est inutilisable...

BsAlv · Answer

Il faut éviter tout ce qu'il y a qui ralentit la macro, utiliser le statusbar ou un textbox pour montrer le progress. Dès q'on a fait cela, il n'y a plus de nécessité d'un barre ... ...

BsAlv · Answer

Un ptit essai pour vous montrer un userform Sub RandomX() Dim iFin As Integer: iFin = 100 UserForm1.Show 0 'montrer l'UF For i = 0 To iFin If i Mod 2 = 0 Then UserForm1.TextBox1.text = "progress = " & i & " sur " & iFin 'mise à jour de l'UF t = Timer 'autre partie de la macro Do While t + 0.2 &gt; Timer DoEvents Loop Next UserForm1.TextBox1.text = "" UserForm1.Hide MsgBox "fini !" End Sub...