macro fonctionnant dans les sous-répertoire

[flosauveur69]

Bonjour à tous,

J'ai une macro qui fonctionne quand je met le classeur mère dans le dossier où se trouve les classeurs fils.

Cependant, j'aimerais que le classeur mère se trouvent à l'extérieur du dossier où se trouvent les classeurs fils. Jusque là ça va mais les classeurs fils sont en fait dans des sous répertoire du dossier.

Dans la macro ci-dessous, j'ai donc remplacé cette ligne

strFile = Dir(ThisWorkbook.Path & "\*.xls")

par

strFile = Dir("D:\Documents and Settings\fl\Bureau\excel" & "\SousRepertoire\*.xls")

cependant cela ne fonctionne pas

Private Sub cmdRecupere_Click()
Dim intFile As Integer
Dim strWB As String
Dim strFile As String
Dim lgDerLig As Long

Application.ScreenUpdating = False
Application.EnableEvents = False

' Nom du classeur actuel
strWB = ThisWorkbook.Name

lgDerLig = 2

' Récupération du premier fichier dans le répertoire et sous repertoire
strFile = Dir(ThisWorkbook.Path & "\SousRepertoire\*.xls")

' Boucle du 1er au dernier classeur dans le répertoire et sous repertoire
Do While strFile <> ""
' Si le classeur n'est pas "Total.xls" et si son nom n'existe pas en colonne C
If strFile <> strWB And Worksheets("Feuil1").Columns("C").Find(strFile, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
' Ouvrir le fichier
Workbooks.Open ThisWorkbook.Path & "\" & strFile

' Sélectionner le 1er onglet
ActiveWorkbook.Worksheets(1).Activate
' Copier la sélection dans le classeur
Worksheets(1).Range("A13:B28").Copy Destination:=Workbooks(strWB).Worksheets("Feuil1").Range("A" & lgDerLig)
Workbooks(strWB).Worksheets("Feuil1").Range("C" & lgDerLig) = strFile
lgDerLig = lgDerLig + 16 'il me semble, puique la hauteur copiée est de 16...

' Fermeture du classeur
Workbooks(strFile).Close
End If

' Classeur suivant
strFile = Dir
Loop

MsgBox "Le traitement des fichiers est terminé.", vbInformation, "Traitement..."

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub



MERCI de votre aide

 

[Paritec]

Re : macro fonctionnant dans les sous-répertoire

Bonsoir flosauveur69 ,le forum

alors ton chemin tu es sur qu'il existe ?  Il paraît bizarre!!!!
strFile = Dir("D:\Documents and Settings\fl\Bureau\[COLOR=Red]excel[/COLOR]" & "\[COLOR=Red]SousRepertoire[/COLOR]\*.xls")

a+
papou

EDIT bonsoir Bruno

 

[Compte Supprimé 979]

Re : macro fonctionnant dans les sous-répertoire

Salut Flosauveur69, Paritec

Ton problème viens du chemin d'accès que tu ne mets pas dans une variable, d'où une erreur quand tu veux ouvrir ton classeur

Private Sub cmdRecupere_Click()
  Dim intFile As Integer
  Dim strWB As String
  Dim strFile As String
  Dim lgDerLig As Long
  Dim VPath As String
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  ' Nom du classeur actuel
  strWB = ThisWorkbook.Name
  lgDerLig = 2
  ' Récupération du premier fichier dans le répertoire et sous repertoire
  VPath = ThisWorkbook.Path & "\SousRepertoire\"
  strFile = Dir(VPath & "*.xls")
  ' Boucle du 1er au dernier classeur dans le répertoire et sous repertoire
  Do While strFile <> ""
    ' Si le classeur n'est pas "Total.xls" et si son nom n'existe pas en colonne C
    If strFile <> strWB And Worksheets("Feuil1").Columns("C").Find(strFile, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
      ' Ouvrir le fichier
      Workbooks.Open VPath & strFile
      ' Sélectionner le 1er onglet
      ActiveWorkbook.Worksheets(1).Activate
      ' Copier la sélection dans le classeur
      Worksheets(1).Range("A13:B28").Copy Destination:=Workbooks(strWB).Worksheets("Feuil1").Range("A" & lgDerLig)
      Workbooks(strWB).Worksheets("Feuil1").Range("C" & lgDerLig) = strFile
      lgDerLig = lgDerLig + 16  'il me semble, puique la hauteur copiée est de 16...
      ' Fermeture du classeur
      Workbooks(strFile).Close
    End If
    ' Classeur suivant
    strFile = Dir
  Loop
  MsgBox "Le traitement des fichiers est terminé.", vbInformation, "Traitement..."
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub

A+

 

[flosauveur69]

Re : macro fonctionnant dans les sous-répertoire

Bonjour à tous,

merci cependant cette macro ne fonctionne pas, en fait je veux stocker mon fichier mère n'importe où sur le DD et qu'il me récupère les données dans les multiples sous-répertoire (dont le nombre peut augmenter) du répertoire D:\Documents and Settings\fl\Bureau\excel (qui existe bien)

merci de votre aide

 

[sousou]

Re : macro fonctionnant dans les sous-répertoire

Bonjour
Si je ne me trompe pas,
supprime les lignes que j'ai mis entre deux /
et ajoute celles que j'ai mise entre []

Private Sub cmdRecupere_Click()
Dim intFile As Integer
Dim strWB As String
Dim strFile As String
Dim lgDerLig As Long

Application.ScreenUpdating = False
Application.EnableEvents = False

' Nom du classeur actuel
strWB = ThisWorkbook.Name

lgDerLig = 2

[chemin="D:\Documents and Settings\fl\Bureau\excel" & "\SousRepertoire\"]

' Récupération du premier fichier dans le répertoire et sous repertoire

/strFile = Dir(ThisWorkbook.Path & "\SousRepertoire\*.xls")/
[strFile = Dir(chemin & "*.xls")]

' Boucle du 1er au dernier classeur dans le répertoire et sous repertoire
Do While strFile <> ""
' Si le classeur n'est pas "Total.xls" et si son nom n'existe pas en colonne C
If strFile <> strWB And Worksheets("Feuil1").Columns("C").Find(strFile, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
' Ouvrir le fichier

/Workbooks.Open ThisWorkbook.Path & "\" & strFile/
[workbooks.open chemin & srtfile]

' Sélectionner le 1er onglet
ActiveWorkbook.Worksheets(1).Activate
' Copier la sélection dans le classeur
Worksheets(1).Range("A13:B28").Copy Destination:=Workbooks(strWB).Worksheets("Feuil1") .Range("A" & lgDerLig)
Workbooks(strWB).Worksheets("Feuil1").Range("C" & lgDerLig) = strFile
lgDerLig = lgDerLig + 16 'il me semble, puique la hauteur copiée est de 16...

' Fermeture du classeur
Workbooks(strFile).Close
End If

' Classeur suivant
strFile = Dir
Loop

MsgBox "Le traitement des fichiers est terminé.", vbInformation, "Traitement..."

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

 

[flosauveur69]

Re : macro fonctionnant dans les sous-répertoire

Re les amis,

cette macro ne fonctionne toujours pas, je suis pas sur que & "\SousRepertoire\" sélectionne tous les sous-répertoires de D:\Documents and Settings\flechiar\Bureau\testlist\test\ d'autant plus que le nombre de répertoire peut augmenter

Merci beaucoup


Private Sub cmdRecupere_Click()
Dim intFile As Integer
Dim strWB As String
Dim strFile As String
Dim lgDerLig As Long

Application.ScreenUpdating = False
Application.EnableEvents = False

' Nom du classeur actuel
strWB = ThisWorkbook.Name

lgDerLig = 2

chemin = "D:\Documents and Settings\flechiar\Bureau\testlist\test\" & "\SousRepertoire\"

' Récupération du premier fichier dans le répertoire et sous repertoire
strFile = Dir(chemin & "*.xls")

' Boucle du 1er au dernier classeur dans le répertoire et sous repertoire
Do While strFile <> ""
' Si le classeur n'est pas "Total.xls" et si son nom n'existe pas en colonne C
If strFile <> strWB And Worksheets("Feuil1").Columns("C").Find(strFile, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
' Ouvrir le fichier
Workbooks.Open chemin & srtfile

' Sélectionner le 1er onglet
ActiveWorkbook.Worksheets(1).Activate
' Copier la sélection dans le classeur
Worksheets(1).Range("A13:B28").Copy Destination:=Workbooks(strWB).Worksheets("Feuil1").Range("A" & lgDerLig)
Workbooks(strWB).Worksheets("Feuil1").Range("C" & lgDerLig) = strFile
lgDerLig = lgDerLig + 16 'il me semble, puique la hauteur copiée est de 16...

' Fermeture du classeur
Workbooks(strFile).Close
End If

' Classeur suivant
strFile = Dir
Loop

MsgBox "Le traitement des fichiers est terminé.", vbInformation, "Traitement..."

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

 

[Paritec]

Re : macro fonctionnant dans les sous-répertoire

Bonjour flosauveur69 et tous,
tu vas ma trouver pénible mais tout ton souci est dans le chemin
alors quand tu mets Excel\ sous répertoire c'est que tu as un dossier Sous répertoire !!!!!!!!!!!!!
Pour connaître ton chemin, celui qu'il faut donner à ta macro
tu vas dans un des fichiers que tu souhaites ouvrir, et là tu tapes

sub info()
Msgbox thisworkbook.path
end sub

Et là tu auras le chemin qu'il faut donner à ta macro pour chercher les autres fichiers
a+
Papou

 

[sousou]

Re : macro fonctionnant dans les sous-répertoire

Re
Mais donne nous exactement la structure de tes sous-répertoires
UIl sont dans...test\sousrépertoires\
ou dans test\
?

 

[flosauveur69]

Re : macro fonctionnant dans les sous-répertoire

je vous met une impression écran de mon répertoire avec ses 2 sous répertoire : test1 et test2

merci

 

[Paritec]

Re : macro fonctionnant dans les sous-répertoire

re
et tes fichiers à traiter sont dans test1 et test2 ou il y a encore des dossiers?
a+
Papou

 

[sousou]

Re : macro fonctionnant dans les sous-répertoire

re bonjour à tous

Ci_dessous une méthode pour sélectionner tous lesz fichiers de tous les répertoires
à Toi de l'adapter




Sub deb()
Dim reps As New Collection

'ici définis le chemin exact pour accéder à tes fichier
chemin = ThisWorkbook.Path & "\test\"
'------------------------------------------------
rep = Dir(chemin, vbDirectory)
While rep <> ""
reps.Add rep
rep = Dir()
Wend

For Each rep In reps
If rep <> "." And rep <> ".." Then
fich = Dir(chemin & rep & "\")
While fich <> ""
Call traitement(fich)
fich = Dir()
Wend
End If
Next
End Sub

Sub traitement(f)
MsgBox f
End Sub

 

[flosauveur69]

Re : macro fonctionnant dans les sous-répertoire

Re,

alors les fichiers sont soit dans les sous-répertoire test1 et test2 soit dans des sous- sous répertoire dans test1 et test2, il y en a de partout je sais, mais ce n'est pas moi qui gère cela, c'est une copie d'un dossier qui est sur le réseau de mon entreprise.
De plus, il se peut qu'il y ai d'autres sous répertoire que test1 et test2 qui apparaisse dans test.

Merci d'avance pour ton aide

 

[flosauveur69]

Re : macro fonctionnant dans les sous-répertoire

re bonjour à tous

Ci_dessous une méthode pour sélectionner tous lesz fichiers de tous les répertoires
à Toi de l'adapter




Sub deb()
Dim reps As New Collection

'ici définis le chemin exact pour accéder à tes fichier
chemin = ThisWorkbook.Path & "\test\"
'------------------------------------------------
rep = Dir(chemin, vbDirectory)
While rep <> ""
reps.Add rep
rep = Dir()
Wend

For Each rep In reps
If rep <> "." And rep <> ".." Then
fich = Dir(chemin & rep & "\")
While fich <> ""
Call traitement(fich)
fich = Dir()
Wend
End If
Next
End Sub

Sub traitement(f)
MsgBox f
End Sub

Je te remercie vivement et te dis si j'ai des soucis. Par contre je suppose que je dois mettre ce bout de code dans la même feuille que ma macro et avant?

 

[flosauveur69]

Re : macro fonctionnant dans les sous-répertoire

Bonjour,

je viens déterrer ce topic, car je ne récupère plus les mêmes données ni dans le même répertoire mais j`ai toujours ce même problème donc je préfère ne pas créer un nouveau topic.

J`ai la macro suivante avec lesquels je veux récupérer les données de fichiers html qui sont dans le même répertoire que mon classeur Excel. Jusque-là cela fonctionne par contre je n`arrive pas a récupérer les données qui sont dans les sous répertoire car il y des fichier html aussi dans les sous répertoire. Autre problème, les sous répertoire ne sont pas figés et il peut y en avoir des nouveaux.

Je vous mets mon arborescence en PJ.

Merci d`avance.


Public Sub cmdRecupere_Click()
Dim strWB As String, strFile As String

Application.ScreenUpdating = False
Application.EnableEvents = False

' Nom du classeur actuel
strWB = ThisWorkbook.Name

' Récupération du premier fichier dans le répertoire et sous repertoire
strFile = Dir(ThisWorkbook.Path & "\*.html")

' Boucle du 1er au dernier classeur dans le répertoire et sous repertoire
Do While strFile <> ""
' Si le classeur n'est pas "Total.xls" et si son nom n'existe pas en colonne C
If strFile <> strWB And Worksheets("AV_AP_DVR1").Columns("C").Find(strFile, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
' Ouvrir le fichier
Workbooks.Open ThisWorkbook.Path & "\" & strFile

' Copie des données
Workbooks(strFile).Worksheets(1).Range("A13:C28").Copy
With Workbooks(strWB).Worksheets("AV_AP_DVR1")
.Range("A2").Insert xlDown 'insertion en ligne 2
.Range("c2:c17").ClearContents 'on ne garde que les données A2:B17
.Range("C2") = strFile
End With

' Fermeture du classeur
Workbooks(strFile).Close
End If

' Classeur suivant
strFile = Dir
Loop

Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Le traitement des fichiers est terminé.", vbInformation, "Traitement..."
End Sub

 

[Compte Supprimé 979]

Re : macro fonctionnant dans les sous-répertoire

Bonjour Flosauveur69

Le code ne traite pas la redondance des sous-répertoires,
effectue une recherche sur le forum à ce sujet

A+