Parcourir tous les classeurs d'un répertoire sous Excel 2003

JB

05/07/2008 à 15:59

Bonjour,

Sub ListeFichiers()
repertoire = ThisWorkbook.Path
nf = Dir(repertoire & "*.xls") ' premier fichier XLS du
répertoire
Do While nf <> ""
MsgBox nf
nf = Dir ' suivant
Loop
End Sub

JB
http://boisgontierjacques.free.fr/

On 5 juil, 15:28, "Altair" @videotron.ca> wrote:

Bonjour,

Je désire faire un script qui sucessivement ouvre tous les classeurs d' un
répertoire, fait une vérification sur un onglet particulier et si la valeur
en stock est différente de 0 laisse le classeur ouvert pour me permettr e de
faire un traitement manuel, sinon referme le classeur sans enregistrer.

J'ai déjà réalisé un sub qui fait la vérification et ferme le c lasseur si
requis, il me reste à réaliser la partie qui parcouure tous les class eurs du
répertoire. A date je n'ai que

Workbooks.Open Filename:="nomfichier.xls"

mais il me faudrait nommer dans le script chaque classeur du répertoire et
en faire la mise à jour à chaque fois qu'un classeur est ajouté ou retiré,
pas pratique...

Merci à l'avance de votre aide

Sylvain Dupuis

Druuna

05/07/2008 à 16:00

Bonjour Sylvain,

peut-être que ceci pourra t'aider:
http://excelabo.net/excel/fichiersouvrir.php#fichiersrépertoire

Mais juste pour savoir:
Plutot que d'ouvrir tous les fichiers et de refermer ceux dont tu n'a pas
besoin, pourquoi ne demandes-tu pas d'ouvrir uniquement ceux qu'il faudra
modifier ?
Je dis ça comme ça... ça peut permettre de gagner du temps et des ressources
systeme (affichage)

Druuna

"Altair" @videotron.ca> a écrit dans le message de
news:

Bonjour,

Je désire faire un script qui sucessivement ouvre tous les classeurs d'un
répertoire, fait une vérification sur un onglet particulier et si la
valeur en stock est différente de 0 laisse le classeur ouvert pour me
permettre de faire un traitement manuel, sinon referme le classeur sans
enregistrer.

J'ai déjà réalisé un sub qui fait la vérification et ferme le classeur si
requis, il me reste à réaliser la partie qui parcouure tous les classeurs
du répertoire. A date je n'ai que

Workbooks.Open Filename:="nomfichier.xls"

mais il me faudrait nommer dans le script chaque classeur du répertoire et
en faire la mise à jour à chaque fois qu'un classeur est ajouté ou retiré,
pas pratique...

Merci à l'avance de votre aide

Sylvain Dupuis

Altair

05/07/2008 à 16:39

Merci pour les deux réponses rapides,

Je ne savais pas qu'on pouvais faire des vérifications dans un classeur sans
l'ouvrir

Sylvain.

"Druuna" <druuna.x19(supprimerceci)@free.fr> a écrit dans le message de
news: %

Bonjour Sylvain,

peut-être que ceci pourra t'aider:
http://excelabo.net/excel/fichiersouvrir.php#fichiersrépertoire

Mais juste pour savoir:
Plutot que d'ouvrir tous les fichiers et de refermer ceux dont tu n'a pas
besoin, pourquoi ne demandes-tu pas d'ouvrir uniquement ceux qu'il faudra
modifier ?
Je dis ça comme ça... ça peut permettre de gagner du temps et des
ressources systeme (affichage)

Druuna

"Altair" @videotron.ca> a écrit dans le message de
news:
Bonjour,

Je désire faire un script qui sucessivement ouvre tous les classeurs d'un
répertoire, fait une vérification sur un onglet particulier et si la
valeur en stock est différente de 0 laisse le classeur ouvert pour me
permettre de faire un traitement manuel, sinon referme le classeur sans
enregistrer.

J'ai déjà réalisé un sub qui fait la vérification et ferme le classeur si
requis, il me reste à réaliser la partie qui parcouure tous les classeurs
du répertoire. A date je n'ai que

Workbooks.Open Filename:="nomfichier.xls"

mais il me faudrait nommer dans le script chaque classeur du répertoire
et en faire la mise à jour à chaque fois qu'un classeur est ajouté ou
retiré, pas pratique...

Merci à l'avance de votre aide

Sylvain Dupuis

Hervé

06/07/2008 à 17:26

Bonsoir Altair,

Le code ci-dessous recherche les classeurs dans le dossier indiqué, lit la
valeur dans la cellule de la feuille (les deux étant passées en argument) et
si la valeur est égale à zéro le classeur est ouvert. Si la feuille n'existe
pas, un message en fin de procédure indique les classeurs concernés. La
proc. à lancer est "Recup"

Sub Recup()
Dim Tbl() As String
Dim Retour()
Dim Test As Integer
Dim I As Integer
Dim Msg As String
Dim Dossier As String
Dim Feuille As String
Dim Cellule As String

'*** Effectuer les modifs ici ***
'dossier de recherche
Dossier = "F:"
'nom de la feuille (qui doit être
'identique pour tous les classeurs)
Feuille = "Feuil1"
'adresse de la cellule
Cellule = "C4"
'***

Tbl() = Classeur(Dossier)

'teste si au moins 1 fichier est retourné
On Error Resume Next
Test = UBound(Tbl())
If Err.Number <> 0 Then
MsgBox "Le dossier '" & Dossier _
& "' ne contient aucun fichier Excel !"
Err.Clear
Exit Sub
End If

For I = 1 To UBound(Tbl())
ReDim Preserve Retour(1 To I)
Retour(I) = RecupValeur(Dossier, _
Dir(Tbl(I)), _
Feuille, _
Cellule)
Next I

Application.ScreenUpdating = False

For I = 1 To UBound(Retour())
'si la feuille n'existe pas, une erreur
'est retournée. Les noms des classeurs
'concernés sont rérupérés pour affichage
If TypeName(Retour(I)) = "Error" Then
Msg = Msg & Tbl(I) & vbCrLf
'si la valeur de la cellule est 0
'le classeur est ouvert
ElseIf Retour(I) = 0 Then
Workbooks.Open (Tbl(I))
End If
Next I

Application.ScreenUpdating = True

If Msg <> "" Then
MsgBox "La feuille des classeurs ci-dessous " & _
"n'existe pas ou est mal orthographiée !" & _
vbCrLf & vbCrLf & Msg, _
vbExclamation, "Recherche de valeur."
End If

End Sub

Private Function Classeur(Dossier As String) As String()
Dim Tbl() As String
Dim I As Integer
With Application.FileSearch
.NewSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = Dossier
.SearchSubFolders = False 'pas les sous-dossiers
.Execute msoSortByFileName, msoSortOrderAscending
If .Execute > 0 Then
With .FoundFiles
For I = 1 To .Count
ReDim Preserve Tbl(1 To I)
Tbl(I) = .Item(I)
Next I
End With
End If
End With
Classeur = Tbl()
End Function

Function RecupValeur(Chemin As String, _
NomClasseur As String, _
NomFeuille As String, _
Cellule As String)

Dim Arg As String

'vérifie si l'anti slash existe
'sinon le rajoute
If Right(Chemin, 1) <> "" Then Chemin = Chemin & ""

'si c'est une plage, affiche
'un message et fin de procédure
If InStr(Cellule, ":") Then
MsgBox "Une seule cellule en argument", , _
"Cellule unique."
Exit Function
End If
'ignore l'erreur si la plage est
'déjà en référence R1C1
On Error Resume Next
'transforme la référence en style R1C1
Cellule = Range(Cellule).Address(, , xlR1C1)

'construit l'argument
Arg = "'" & Chemin & "[" & NomClasseur & "]" _
& NomFeuille & "'!" & Cellule

'passe la valeur à la fonction
RecupValeur = Application.ExecuteExcel4Macro(Arg)

End Function

Hervé.

"Altair" @videotron.ca> a écrit dans le message de
news:

Bonjour,

Je désire faire un script qui sucessivement ouvre tous les classeurs d'un
répertoire, fait une vérification sur un onglet particulier et si la
valeur en stock est différente de 0 laisse le classeur ouvert pour me
permettre de faire un traitement manuel, sinon referme le classeur sans
enregistrer.

J'ai déjà réalisé un sub qui fait la vérification et ferme le classeur si
requis, il me reste à réaliser la partie qui parcouure tous les classeurs
du répertoire. A date je n'ai que

Workbooks.Open Filename:="nomfichier.xls"

mais il me faudrait nommer dans le script chaque classeur du répertoire et
en faire la mise à jour à chaque fois qu'un classeur est ajouté ou retiré,
pas pratique...

Merci à l'avance de votre aide

Sylvain Dupuis

Bonsoir Altair,

Le code ci-dessous recherche les classeurs dans le dossier indiqué, lit la
valeur dans la cellule de la feuille (les deux étant passées en argument) et
si la valeur est égale à zéro le classeur est ouvert. Si la feuille n'existe
pas, un message en fin de procédure indique les classeurs concernés. La
proc. à lancer est "Recup"

Sub Recup()
Dim Tbl() As String
Dim Retour()
Dim Test As Integer
Dim I As Integer
Dim Msg As String
Dim Dossier As String
Dim Feuille As String
Dim Cellule As String

'*** Effectuer les modifs ici ***
'dossier de recherche
Dossier = "F:"
'nom de la feuille (qui doit être
'identique pour tous les classeurs)
Feuille = "Feuil1"
'adresse de la cellule
Cellule = "C4"
'***

Tbl() = Classeur(Dossier)

'teste si au moins 1 fichier est retourné
On Error Resume Next
Test = UBound(Tbl())
If Err.Number <> 0 Then
MsgBox "Le dossier '" & Dossier _
& "' ne contient aucun fichier Excel !"
Err.Clear
Exit Sub
End If

For I = 1 To UBound(Tbl())
ReDim Preserve Retour(1 To I)
Retour(I) = RecupValeur(Dossier, _
Dir(Tbl(I)), _
Feuille, _
Cellule)
Next I

Application.ScreenUpdating = False

For I = 1 To UBound(Retour())
'si la feuille n'existe pas, une erreur
'est retournée. Les noms des classeurs
'concernés sont rérupérés pour affichage
If TypeName(Retour(I)) = "Error" Then
Msg = Msg & Tbl(I) & vbCrLf
'si la valeur de la cellule est 0
'le classeur est ouvert
ElseIf Retour(I) = 0 Then
Workbooks.Open (Tbl(I))
End If
Next I

Application.ScreenUpdating = True

If Msg <> "" Then
MsgBox "La feuille des classeurs ci-dessous " & _
"n'existe pas ou est mal orthographiée !" & _
vbCrLf & vbCrLf & Msg, _
vbExclamation, "Recherche de valeur."
End If

End Sub

Private Function Classeur(Dossier As String) As String()
Dim Tbl() As String
Dim I As Integer
With Application.FileSearch
.NewSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = Dossier
.SearchSubFolders = False 'pas les sous-dossiers
.Execute msoSortByFileName, msoSortOrderAscending
If .Execute > 0 Then
With .FoundFiles
For I = 1 To .Count
ReDim Preserve Tbl(1 To I)
Tbl(I) = .Item(I)
Next I
End With
End If
End With
Classeur = Tbl()
End Function

Function RecupValeur(Chemin As String, _
NomClasseur As String, _
NomFeuille As String, _
Cellule As String)

Dim Arg As String

'vérifie si l'anti slash existe
'sinon le rajoute
If Right(Chemin, 1) <> "" Then Chemin = Chemin & ""

'si c'est une plage, affiche
'un message et fin de procédure
If InStr(Cellule, ":") Then
MsgBox "Une seule cellule en argument", , _
"Cellule unique."
Exit Function
End If
'ignore l'erreur si la plage est
'déjà en référence R1C1
On Error Resume Next
'transforme la référence en style R1C1
Cellule = Range(Cellule).Address(, , xlR1C1)

'construit l'argument
Arg = "'" & Chemin & "[" & NomClasseur & "]" _
& NomFeuille & "'!" & Cellule

'passe la valeur à la fonction
RecupValeur = Application.ExecuteExcel4Macro(Arg)

End Function

Hervé.

"Altair" <sylvain.dupuis@NoSpam@videotron.ca> a écrit dans le message de
news: eTvQRNq3IHA.3480@TK2MSFTNGP03.phx.gbl...

Bonjour,

Je désire faire un script qui sucessivement ouvre tous les classeurs d'un
répertoire, fait une vérification sur un onglet particulier et si la
valeur en stock est différente de 0 laisse le classeur ouvert pour me
permettre de faire un traitement manuel, sinon referme le classeur sans
enregistrer.

J'ai déjà réalisé un sub qui fait la vérification et ferme le classeur si
requis, il me reste à réaliser la partie qui parcouure tous les classeurs
du répertoire. A date je n'ai que

Workbooks.Open Filename:="nomfichier.xls"

mais il me faudrait nommer dans le script chaque classeur du répertoire et
en faire la mise à jour à chaque fois qu'un classeur est ajouté ou retiré,
pas pratique...

Merci à l'avance de votre aide

Sylvain Dupuis

Vous avez filtré cet utilisateur ! Consultez son message

Bonsoir Altair,

Le code ci-dessous recherche les classeurs dans le dossier indiqué, lit la
valeur dans la cellule de la feuille (les deux étant passées en argument) et
si la valeur est égale à zéro le classeur est ouvert. Si la feuille n'existe
pas, un message en fin de procédure indique les classeurs concernés. La
proc. à lancer est "Recup"

Sub Recup()
Dim Tbl() As String
Dim Retour()
Dim Test As Integer
Dim I As Integer
Dim Msg As String
Dim Dossier As String
Dim Feuille As String
Dim Cellule As String

'*** Effectuer les modifs ici ***
'dossier de recherche
Dossier = "F:"
'nom de la feuille (qui doit être
'identique pour tous les classeurs)
Feuille = "Feuil1"
'adresse de la cellule
Cellule = "C4"
'***

Tbl() = Classeur(Dossier)

'teste si au moins 1 fichier est retourné
On Error Resume Next
Test = UBound(Tbl())
If Err.Number <> 0 Then
MsgBox "Le dossier '" & Dossier _
& "' ne contient aucun fichier Excel !"
Err.Clear
Exit Sub
End If

For I = 1 To UBound(Tbl())
ReDim Preserve Retour(1 To I)
Retour(I) = RecupValeur(Dossier, _
Dir(Tbl(I)), _
Feuille, _
Cellule)
Next I

Application.ScreenUpdating = False

For I = 1 To UBound(Retour())
'si la feuille n'existe pas, une erreur
'est retournée. Les noms des classeurs
'concernés sont rérupérés pour affichage
If TypeName(Retour(I)) = "Error" Then
Msg = Msg & Tbl(I) & vbCrLf
'si la valeur de la cellule est 0
'le classeur est ouvert
ElseIf Retour(I) = 0 Then
Workbooks.Open (Tbl(I))
End If
Next I

Application.ScreenUpdating = True

If Msg <> "" Then
MsgBox "La feuille des classeurs ci-dessous " & _
"n'existe pas ou est mal orthographiée !" & _
vbCrLf & vbCrLf & Msg, _
vbExclamation, "Recherche de valeur."
End If

End Sub

Private Function Classeur(Dossier As String) As String()
Dim Tbl() As String
Dim I As Integer
With Application.FileSearch
.NewSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = Dossier
.SearchSubFolders = False 'pas les sous-dossiers
.Execute msoSortByFileName, msoSortOrderAscending
If .Execute > 0 Then
With .FoundFiles
For I = 1 To .Count
ReDim Preserve Tbl(1 To I)
Tbl(I) = .Item(I)
Next I
End With
End If
End With
Classeur = Tbl()
End Function

Function RecupValeur(Chemin As String, _
NomClasseur As String, _
NomFeuille As String, _
Cellule As String)

Dim Arg As String

'vérifie si l'anti slash existe
'sinon le rajoute
If Right(Chemin, 1) <> "" Then Chemin = Chemin & ""

'si c'est une plage, affiche
'un message et fin de procédure
If InStr(Cellule, ":") Then
MsgBox "Une seule cellule en argument", , _
"Cellule unique."
Exit Function
End If
'ignore l'erreur si la plage est
'déjà en référence R1C1
On Error Resume Next
'transforme la référence en style R1C1
Cellule = Range(Cellule).Address(, , xlR1C1)

'construit l'argument
Arg = "'" & Chemin & "[" & NomClasseur & "]" _
& NomFeuille & "'!" & Cellule

'passe la valeur à la fonction
RecupValeur = Application.ExecuteExcel4Macro(Arg)

End Function

Hervé.

"Altair" @videotron.ca> a écrit dans le message de
news:

Bonjour,

Je désire faire un script qui sucessivement ouvre tous les classeurs d'un
répertoire, fait une vérification sur un onglet particulier et si la
valeur en stock est différente de 0 laisse le classeur ouvert pour me
permettre de faire un traitement manuel, sinon referme le classeur sans
enregistrer.

J'ai déjà réalisé un sub qui fait la vérification et ferme le classeur si
requis, il me reste à réaliser la partie qui parcouure tous les classeurs
du répertoire. A date je n'ai que

Workbooks.Open Filename:="nomfichier.xls"

mais il me faudrait nommer dans le script chaque classeur du répertoire et
en faire la mise à jour à chaque fois qu'un classeur est ajouté ou retiré,
pas pratique...

Merci à l'avance de votre aide

Sylvain Dupuis

Parcourir tous les classeurs d'un répertoire sous Excel 2003

4 réponses

Veuillez sélectionner un problème