Intégration d'une barre de progression

[massol]

Bonjour,

Dans le code ci-dessous je souhaiterais intégrer une barre de progression de la macro. Des suggestions ?
Merci par avance.

Cdlt.
Jérôme

Sub Delayed()

'Déclaration des variables
Dim ID As String
Dim nbr As Integer
Dim Derlig As Integer
Dim x As String
Dim y As Integer
Dim i As Integer
Dim Program As String
Dim PO As String
Dim PO_Date As Date
Dim Content As String
Dim Deliv_Target_Date As Date
Dim Deliv_Date_OTD1 As Date
Dim Deliv_Time_OTD1 As String

'Effacer la zone B3 à C1000
Range("B3:C1000").Select
Selection.ClearContents

'La mise à jour du tableau doit impérativement avoir été effectuée ("FOLLOW_UP_TEST.xlsm" ; onglet "Feuil1).
If MsgBox("Have you updated the table from the tab 'Feuil1' ?", vbYesNo, "Confirmation Request") = vbNo Then
MsgBox ("Thank you for updating the 'Feuil1' tab.")
Windows("FOLLOW_UP_TEST.xlsm").Activate
Sheets("Feuil1").Activate
Exit Sub
Else
End If

'Permet de ne pas avoir à cliquer sur OK à chaque fois que c'est demandé (msgbox). Ainsi la validation est automatique
Application.EnableEvents = False

'On se positionne dans le fichier "FOLLOW_UP_TEST.xlsm" et dans l'onglet "Feuil1"
Windows("FOLLOW_UP_TEST.xlsm").Activate
Sheets("Feuil1").Activate

Dossier_racine = Range("Z1").Value
'MsgBox ("Dossier racine = " & Dossier_racine)

nbr = 0

'Recherche du numéro de la dernière ligne non vide en partant de B6 (dernier ID) --> derlig
'Recherche du nombre de références ID en colonne B --> nbr
Derlig = Application.WorksheetFunction.CountA(Range("B:B")) + 3
nbr = Range("B6:B" & Derlig).SpecialCells(xlCellTypeVisible).Count

'MsgBox ("Derlig = " & Derlig)

'Affichage dans une boite de dialogue du nombre de références ID
MsgBox ("You have " & nbr & " ID's references")

'Initialisation des compteurs (on part de la ligne 6)
i = 1
y = 6

'Boucle sur le nombre de références ID, nbr (remplissage du tableau)
While i <= nbr

'MsgBox ("i = " & i)
'MsgBox ("y = " & y)

'On se positionne dans le fichier "FOLLOW_UP_TEST.xlsm" et dans l'onglet "Feuil1"
Windows("FOLLOW_UP_TEST.xlsm").Activate
Sheets("Feuil1").Activate

'x correspond à la valeur de la cellule B6 (à la première boucle, première valeur de la liste)
x = Range("B" & y).Value


'MsgBox ("x = " & x)

'MsgBox ("Dossier racine = " & Dossier_racine)

'Ouverture du fichier "Entry_Form_ID.....xlsm" situé dans le dossier racine auquel on rajoute le sous-dossier ID....
'Activation de l'onglet "ADD_INFOS"
Workbooks.Open Filename:=Dossier_racine & "\" & x & "\" & "Entry_Form_" & x & ".xlsm"
Sheets("ADD_INFOS").Activate

'MsgBox ("on est dans " & "Entry_Form_" & x & ".xlsm" & " onglet ADD_INFOS")

'Récupération de la date OTD1
Deliv_Time_OTD1 = Range("H9").Value

'MsgBox ("Deliv_Time_OTD1 = " & Deliv_Time_OTD1)

If Deliv_Time_OTD1 = "On time" Then

'MsgBox ("on est dans le cas où c'est On time")
'Fermer le fichier "Entry_Form_ID....xlsm" sans l'enregistrer (false)
Workbooks("Entry_Form_" & x & ".xlsm").Close False
y = y + 1
i = i + 1

Else
'MsgBox ("on est dans le cas où c'est DELAYED")
'Mise en mémoire des données du fichier "Entry_Form_ID.....xlsm". Celles-ci sont à rapatrier dans le fichier "FOLLOW_UP_TEST.xlsm"
ID = "ID" & Range("C6").Value
'MsgBox ("ID = " & ID)
Deliv_Date_OTD1 = Range("H8").Value
'MsgBox ("Deliv_Date_OTD1 = " & Deliv_Date_OTD1)

'On active le fichier "FOLLOW_UP_TEST.xlsm" et on se mets dans l'onglet "DELAYED_OTD1"
Windows("FOLLOW_UP_TEST.xlsm").Activate
Sheets("DELAYED_OTD1").Activate

'MsgBox ("on est dans l'onglet DELAYED_OTD1")

'On colle les valeurs précédemment mises en mémoire dans le fichier "FOLLOW_UP_TEST.xlsm" (onglet "DELAYED")
Range("B" & y - 3).Value = ID
'MsgBox ("pause")
Range("C" & y - 3).Value = Deliv_Date_OTD1
'MsgBox ("pause")
y = y + 1
'MsgBox ("y = " & y)
i = i + 1

'MsgBox ("i = " & i)

'Fermer le fichier "Entry_Form_ID....xlsm" sans l'enregistrer (false)
Workbooks("Entry_Form_" & x & ".xlsm").Close False

End If

Wend

'On active le fichier "FOLLOW_UP_TEST.xlsm" et on se mets dans l'onglet "DELAYED_OTD1"
Windows("FOLLOW_UP_TEST.xlsm").Activate
Sheets("DELAYED_OTD1").Activate

Range("A1").Select

MsgBox ("Delayed extract finished")

Application.EnableEvents = True

End Sub

 

[cp4]

Bonsoir Massol,

Tu trouveras des exemples en faisant une recherche sur le forum.

une petite suggestion par rapport au début de ton code, tu peux effacer en une seule fois la plage de cellules. Au lieu de la sélectionner puis l'effacer.

'Effacer la zone B3 à C1000
Range("B3:C1000").ClearContents

'au lieu de
'Effacer la zone B3 à C1000
Range("B3:C1000").Select
Selection.ClearContents

Pour la barre de progression, je ne vois pas l'utilité tu vas rallonger le temps d’exécution.

Bonne soirée.

 

[massol]

Ok. Merci !!!

Cdlt.
Jérôme