progress bar pendant un enregistrement ?

[avoriaz]

salut le forum,

bien je voudrais trouver le moyen d'adapter une macro, progress bar de ti OU thierry mais pendant l'enregistrement d'un classeur !!

en effect comme le classeur est assez lourd je voudrais montrer la progression de l'enregistrement, car l'utilisateurdois attendre au moins 45 seconde pour qu'execel se libere apres enregistrement ?

possible d'adapter la macro progress bar , de ti ?
elle est plutot ecrite pour la fonction rows je trouve ...

merci pour votre aide ...

avo

 

[@+Thierry]

Bonjour Avo, le Forum

Cette question a déjà ete posée plusieurs fois dans le Forum, et j'ai toujours répondu négativement hélas. (Faire des recherches ("Progress", "Enregistrement", "@+Thierry").

Bonne Journée (quand même !)

@+Thierry

 

[Yeahou]

Bonjour avoriaz, Thierry, le forum

On peut utiliser la StatusBar qui a, par défaut, cette barre de progression. Peut être cela te conviendra t'il ?

Cordialement, A+

Sub essai_enregistrement()
oldDisplayStatusBar = Application.DisplayStatusBar
oldStatusbar = Application.StatusBar
Application.StatusBar = False
Application.DisplayStatusBar = True
ActiveWorkbook.Save
Application.StatusBar = oldStatusbar
Application.DisplayStatusBar = oldDisplayStatusBar
End Sub

 

[avoriaz]

Bonjour le forum

merci thierry et Yeahou

ce code avec ce status barre je doir le mettre dans un module?

mon enregistrement de classeur se fais via un usf et un bouton enregistrement....

merci pour votre aide

 

[Yeahou]

Bonjour

poste le code de ton bouton

A+

 

[avoriaz]

RE

VOICI LE CODE
dans mon usf j'ai ceci qui renvoie a un module

Private Sub EnregistrerSous_Click()
Enregistrer

End Sub


Sub Enregistrer()

'Test présence répertoire
Repertoire = "C:\Mes documents\"
If Dir(Repertoire, vbDirectory) = "" Then
MkDir (Repertoire)
End If


'Nouveau nom de fichier
Prenom = InputBox("ENTREZ VOTRE PRENOM")
Nom = InputBox("ENTREZ VOTRE NOM")
Aujourdhui = Format(Now, "dd mmmm yyyy")
Heure = Format(Now, "hh")
Minutes = Right(Format(Now, "hh:mm"), 2)
NomFichier = Prenom & " " & Nom & " " & Aujourdhui & " " & Heure & "h" & Minutes
NomEtChemin = Repertoire & "\" & NomFichier

'Enregistrement sous
EnregistrerSous:
FichierEnregistrerSous = Application.GetSaveAsFilename(NomEtChemin, _
fileFilter:="Fichiers Microsoft Excel (*.xls), *.xls")
If FichierEnregistrerSous <> False Then
Affichage = MsgBox("Vous allez enregistrer " & NomFichier & " sous :" & _
Chr(10) & Chr(10) & FichierEnregistrerSous, , "Enregistrement du fichier")
Else
GoTo LaFin
End If

If Dir(FichierEnregistrerSous) <> "" Then
Affichage = MsgBox("Un fichier du même nom existe déjà à cet emplacement." & _
Chr(10) & Chr(10) & "Renommez le ou supprimer le.", vbExclamation, "NDLR")
GoTo EnregistrerSous
End If

ActiveWorkbook.SaveAs Filename:=FichierEnregistrerSous, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=True
LaFin:
End Sub

car apres l'activation de ce bouton, je memorise la personne la date et l'heure de l'enregistrement ....

mais comme c'est un gros fichier il mets du temps pour faire la save, c'est pour ca j'aurrai voulue une barre de status pendant la save ...

merci pour ton aide

avo

 

[Yeahou]

Re Bonjour

Voila ton code modifié, il fonctionnera sauf si tu as une instruction Application.ScreenUpdating = False en cours.

Cordialement, A+

Sub Enregistrer()

'Test présence répertoire
Repertoire = "C:\Mes documents\"
If Dir(Repertoire, vbDirectory) = "" Then
MkDir (Repertoire)
End If


'Nouveau nom de fichier
Prenom = InputBox("ENTREZ VOTRE PRENOM")
Nom = InputBox("ENTREZ VOTRE NOM")
Aujourdhui = Format(Now, "dd mmmm yyyy")
Heure = Format(Now, "hh")
Minutes = Right(Format(Now, "hh:mm"), 2)
NomFichier = Prenom & " " & Nom & " " & Aujourdhui & " " & Heure & "h" & Minutes
NomEtChemin = Repertoire & "\" & NomFichier

'Enregistrement sous
EnregistrerSous:
FichierEnregistrerSous = Application.GetSaveAsFilename(NomEtChemin, _
fileFilter:="Fichiers Microsoft Excel (*.xls), *.xls")
If FichierEnregistrerSous <> False Then
Affichage = MsgBox("Vous allez enregistrer " & NomFichier & " sous :" & _
Chr(10) & Chr(10) & FichierEnregistrerSous, , "Enregistrement du fichier")
Else
GoTo LaFin
End If

If Dir(FichierEnregistrerSous) <> "" Then
Affichage = MsgBox("Un fichier du même nom existe déjà à cet emplacement." & _
Chr(10) & Chr(10) & "Renommez le ou supprimer le.", vbExclamation, "NDLR")
GoTo EnregistrerSous
End If

oldDisplayStatusBar = Application.DisplayStatusBar
oldStatusbar = Application.StatusBar
Application.StatusBar = False
Application.DisplayStatusBar = True
ActiveWorkbook.SaveAs Filename:=FichierEnregistrerSous, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=True
Application.StatusBar = oldStatusbar
Application.DisplayStatusBar = oldDisplayStatusBar
LaFin:
End Sub

 

[avoriaz]

merci pour ton code, je viens d'essayer, a priori ca marche pas ....

j'ai meme forcer directe en dessous du bouton de mettre

Application.ScreenUpdating = true et lancer l'instruction mais sans resultat

peut etre que je fais une betise ?

merci pour ton aide

 

[Yeahou]

Re Bonjour

si tu veux, je t'envoie un exemple fonctionnel sur ta bal (forcément trop gros pour le forum)

A+

 

[Fréd]

Bonjour tout le monde,
Je serais très intéressée par la proposition de Yeahou concernant le code pour une barre de progression car je suis exactement dans le même cas qu'Avoriaz.
Pourrais-tu me l'envoyer également ?

Merci d'avance

Fréd