Progressbar lié à la statusbar

[Binif]

Bonjour à tous,

Voilà je suis en train de réfléchir à créer un fichier Excel pour afficher le contenu de certaines cellules de plusieurs fichiers, en gros je souhaite regrouper des informations de plusieurs fichiers "BEA100, BEA101, DUP700, DUP800, etc..." sur un seul et même fichier "Récap".

Voici l'organisation:

Mes fichiers sont dans le chemin suivant:
Y:\Excel\BEA100.xlsm
Y:\Excel\BEA101.xlsm
Y:\Excel\DUP700.xlsm
Y:\Excel\DUP800.xlsm
Y:\Excel\etc...

Tous les fichiers dans ce dossier sont issus d'un gabarit identique, ils ont juste des noms différents avec des contenus différents mais sont organisés de la même manière.

Mon fichier récapitulatif est dans :
Y:\Récap.xlsm

Dans le fichier "Récap" j'ai un onglet "BBD" et un onglet "Link"
"Link" contient les liens hypertextes vers chaques fichiers contenu dans le dossier "Y:\Excel\"
le tout étant trié de manière alphanumérique et listé depuis la cellule "D1" via une macro qui se lance à l'ouverture du fichier.

"BBD" doit contenir la valeur de la cellule "F3" de l'onglet "Design" de chaque lien situé dans l'onglet "Link"

Les liens se mettent à jours à l'ouverture car on rajoute des fichiers dans le dossier "Excel" tous les jours.
C'est pour cette raison que je voudrais que les valeurs correspondent aux liens issus de la macro.

Je ne souhaite pas que les fichiers soient ouverts pour obtenir les valeurs car le dossier "Excel" contient plus de 200 fichiers actuellement.

Il est difficle pour moi de vous fournir un exemple de fichier à cause des liens et de la macro qui ne fonctionnera surement pas chez vous.

Voici la macro:

'Recupere les noms de fichiers d'un répertoire dans un tableau
Sub RecupNomFichier(ByVal Chemin As String, ByRef Tableau As Variant)
Dim Fichier As String
Dim Compteur As Integer
Dim LigneCompteur As Integer

Chemin = Range("A2") + "\*.xlsm"
Compteur = 1
Fichier = Dir(Chemin)

Do While (Len(Fichier) > 0)
ReDim Preserve Tableau(Compteur)
Tableau(Compteur - 1) = Fichier
LigneCompteur = Compteur + 1
ActiveSheet.Range("B" & LigneCompteur).Value = Left(Tableau(Compteur - 1), 100)
Compteur = Compteur + 1
Fichier = Dir()
Loop
End Sub
Sub RecupFichierTableau()
On Error Resume Next
Application.ScreenUpdating = False
Dim Tableau() As String
Sheets("Link").Select
Call RecupNomFichier(Chemin, Tableau)
FiltreAlpha

End Sub

Sub FiltreAlpha()
Columns("B:B").Select
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
With Selection
.HorizontalAlignment = xlCenter
.Orientation = 0
End With
With Selection
.HorizontalAlignment = xlLeft
.Orientation = 0
End With
End Sub

Voici la formule dans la case "D1" de la feuille "Link", cette formule est étirée sur 500 lignes (voir plus).

=LIEN_HYPERTEXTE($A$2&B1,$A$2&B1)

Merci à tous ceux qui m'ont lu. et à tous ceux qui vont me répondre.

 

[Binif]

Re: Afficher le contenu de cellules d'un fichier depuis un lien hypertexte

Bonjour,

Je me doute que si je n'ai pas de réponse c'est qu'il n'y a pas de problème vu qu'il n'y a pas de solution...
Alors j'ai modifié ma façon de penser mon fichier récapitulatif.

Plutôt que de lister les fichiers qui sont dans un dossier, je les liste mais j'extraits les données qui m'intéresse en même temps sans liaison vu que le fichier s'update à l'ouverture.

Maintenant j'ai ce qu'il me faut dans mon fichier récapitulatif mais le traitement de la macro étant long 14sec... et mes collaborateurs impatients (clic partout en espérant que cela aille plus vite) il faut que j'adapte une progressbar lié aux nombres de fichier en traitement

Nom du Userform :
frmProgressBar1
Nom de la progressbar dans le userform:
ProgressBar

J'en suis au stade de faire apparaitre mon userform et ma progressbar mais je ne sais pas la lier au statusbar qui lui peut estimer le temps de traitements de la macro.

Si une âme charitable pouvait m'aider, j'ai eu beau chercher, je n'arrive vraiment pas à avoir une synchronisation entre le temps et le statut.

'=========================================================================================================
' Créer un classeur avec une feuille vierge que l'on nommera
' Import ( Nom sans importance ) : propriété Name sous VBE
' ShImport : propriété (Name) sous VBE
'
' Dans environnement VBE
' Recopier l'ensemble du code ci dessous dans un module
' Outils | Références Cocher Microsoft Scripting Runtime
'
' Un bouton est à créer sur la feuille "Import"
' il faut le nommer btnImport et lui affecter la procédure btnImport_QuandClic
'
' Const Dossier As String = "Y:\Excel" à modifier pour pointer sur le dossier désiré
'
'=========================================================================================================
Option Explicit
Dim NbFichiers As Integer
' Dossier des classeurs à traiter
Const Dossier As String = "Y:\Excel"
' On suppose que tous les fichiers contiennent les données dans Design
' Si un onglet ne s'appelle pas NomFeuille
' une erreur #REF! est inscrite dans les cellules concernées
Const NomFeuille As String = "Design"
Private Sub Entete()
With ShImport
' Tout effacer
Sheets("BDD").Select
Range("A1").Select
ActiveSheet.Cells.Clear
' On met le format de cellule désirée
Range("E4:E5000").Select
Selection.NumberFormat = "0%"
Range("G4:G5000").Select
Selection.NumberFormat = "0%"
Range("I4:I5000").Select
Selection.NumberFormat = "0%"
Range("K4:K5000").Select
Selection.NumberFormat = "0%"
Range("F4:F5000").Select
Selection.NumberFormat = "[$-409]dd-mmm-yy;@"
Range("H4:H5000").Select
Selection.NumberFormat = "[$-409]dd-mmm-yy;@"
Range("J4:J5000").Select
Selection.NumberFormat = "[$-409]dd-mmm-yy;@"
Range("L4:L5000").Select
Selection.NumberFormat = "[$-409]dd-mmm-yy;@"
.Range("A3").Formula = "Fichier"
' A tout hasard cela peut être interessant
' d'avoir ces infos sur les fichiers
.Range("B3") = "Date de Création"
.Range("C3") = "Date Dernière Modification"
'D3 E3 F3 G3 H3 I3 J3 K3 L3 M3 N3
.Range("D3") = "Nom responsable"
.Range("E3") = "% Design"
.Range("F3") = "Date"
.Range("G3") = "% Production"
.Range("H3") = "Date"
.Range("I3") = "% Finition"
.Range("J3") = "Date"
.Range("K3") = "% Installation"
.Range("L3") = "Date"
.Range("M3") = "Code"
.Range("N3") = "Titre projet"
.Range("O3") = "Nom client"
End With
End Sub
Sub ListeFichiersDans(ByVal NomDossierSource As String)
Dim NomFichier As String
Dim Tableau() As String
Dim r As Long, i As Long

NomFichier = Dir(NomDossierSource)
Erase Tableau
NbFichiers = 0
Do While Len(NomFichier) > 0
NbFichiers = NbFichiers + 1
ReDim Preserve Tableau(1 To NbFichiers)
Tableau(NbFichiers) = NomFichier
NomFichier = Dir()
Loop

r = Range("A65536").End(xlUp).Row + 1
If NbFichiers > 0 Then
For i = 1 To UBound(Tableau)
Cells(r, 1) = Tableau(i)
r = r + 1
Next
End If
End Sub
' Permet de lire une valeur dans un fichier Excel fermé
Private Function ExtraireValeur(ByVal Dossier As String, ByVal Fichier As String, ByVal Feuille As String, ByVal Cellule As String)
Dim Argument As String
Fichier = Replace(Fichier, "'", "''")
Argument = "'" & Dossier & "[" & Fichier & "]" & Feuille & "'!" & Range(Cellule).Address(, , xlR1C1)
ExtraireValeur = ExecuteExcel4Macro(Argument)
End Function
Sub btnImport()
Dim Debut As Variant
Dim NumeroLigne As Integer, i As Integer
Dim NomFichier As String
Dim DDate As String
Dim DossierOk As String
Dim PctDone As Single

Application.Cursor = xlWait
frmProgressBar1.Show (vbModeless)
frmProgressBar1.Repaint

' Par curiosité
Debut = Time()
Application.ScreenUpdating = False
Entete

DossierOk = Dossier
' Pour éviter le drame du copier/coller ....
If Right(DossierOk, 1) <> "\" Then DossierOk = DossierOk & "\"

ListeFichiersDans DossierOk

' Si un onglet de NomFichier ne s'appelle pas NomFeuille
' une erreur #REF! est incrite dans les cellules concernées

' On démarre à cette ligne
NumeroLigne = 4
For i = 1 To NbFichiers
NomFichier = ShImport.Range("A" & NumeroLigne)

With ShImport
.Cells(NumeroLigne, 4) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "B7")
.Cells(NumeroLigne, 5) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "F3")
.Cells(NumeroLigne, 6) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G3")
.Cells(NumeroLigne, 7) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "F4")
.Cells(NumeroLigne, 8) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G4")
.Cells(NumeroLigne, 9) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "F5")
.Cells(NumeroLigne, 10) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G5")
.Cells(NumeroLigne, 11) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "F6")
.Cells(NumeroLigne, 12) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G6")
.Cells(NumeroLigne, 13) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "A4")
.Cells(NumeroLigne, 14) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "A5")
.Cells(NumeroLigne, 15) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "A2")

' Si Dates à extraire mal formatées
' DDate = ExtraireValeur(DossierOk , NomFichier, NomFeuille, "Cxy" )
' If IsDate(DDate) Then .Cells(NumeroLigne, z) = Format(DDate, "dd/mm/yyyy" )

' Sinon
' .Cells(NumeroLigne, z) = Format(DDate, "dd/mm/yyyy" )

End With

NumeroLigne = NumeroLigne + 1
Application.StatusBar = i & " / " & NbFichiers
Next

Application.StatusBar = "Terminé : " & Format((Time() - Debut) * 100000, "0.00")

' Revenir en haut à gauche
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
End With

With ShImport
.Rows("3:3").Font.Bold = True
.Columns("B:C").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
.Columns("A:I").Columns.AutoFit
.Range("A1").Select
End With
Application.ScreenUpdating = True

frmProgressBar1.Hide

Application.Cursor = xlDefault

Sheets("Récapitulatif").Select
Range("A1").Select

End Sub

 

[Binif]

Bonjour,

Up

J'ai fait des recherches mais je ne trouve pas.

Merci.

 

[Dranreb]

Re : Progressbar lié à la statusbar

Bonsoir.
J'ai cette uf qui affiche une barre de progression, le pourcentage d'accomplissement, le nombre moyen d'opérations élémentaires effectuées par seconde, l'heure prévue de fin de tâche, et enfin le temps restant.
Elle implique juste de passer à une Sub "Tâche" le nombre total d'opérations élémentaires à effectuer (à connaitre donc impérativement avant de commencer), et d'appeler une Sub "OùÇaEnEst" après chaque opération.
À +

 

[Binif]

Bonjour,

Je te remercie;
Je regarde ça;
J'essais de m'adapter;
Je reviens vous dire si j'y arrive.

Merci.