Macro récuperant des données aussi dans les sous-répertoire
Bonjour,
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 à 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 pour votre aide
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
Aucune aide? merci
Bonjour a tous, finalement j`ai trouvé un moyen plus simple, au lieu de sélectionner tous les sous répertoire du répertoire, je voudrais seulement sélectionner les répertoires suivants :
D:\testlist\CMV01
D:\testlist\CMV42
Pourriez-vous m`aider car je modifie le Strfile et le chemin mais la macro ne fonctionne plus ensuite
Et 2eme contrainte si c`est possible, sélectionner les fichiers seulement compris entre 2 dates (les dates pourront être contenu dans des cellules du classeur feuil1 A1 et B1 par exemple)
Apres cela cette macro devrait être nikel, merci à vous
Voici la macro à modifier :
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("Calcul2").Columns("C").Find(strFile, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
' Ouvrir le fichier
Workbooks.Open ThisWorkbook.Path & "\" & strFile
Chemin = ThisWorkbook.Path & "\" & strFile
Set Objet = CreateObject("Scripting.FileSystemObject")
Set Fichier = Objet.GetFile(Chemin)
' Copie des données
Workbooks(strFile).Worksheets(1).Range("A11:C28").Copy
With Workbooks(strWB).Worksheets("Calcul2")
.Range("A2").Insert xlDown 'insertion en ligne 2
.Range("c2:c19").ClearContents 'on ne garde que les données A2:B17
.Range("C3") = strFile
.Range("c2") = Fichier.DateLastModified
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
J`ai trouve solution a mon probleme, pour rappel:
ma Macro doit ouvrir chaque fichier de 2 répertoires, et copier une plage de cellules. Le classeur est ouvert si il n`a jamais été ouvert et si son datelastmodified est compris entre 2 dates.
Le dernier problèmeque je rencontre c`est que quand je compile, j`ai un message d`erreur Object Required
Second problème, la macro ouvre chaque fichier en bas de l`écran avant de copier les données ce qu`elle ne devra pas faire grâce au Application.ScreenUpdating = False
Merci de votre aide
ma macro:
Public Sub cmdRecupere_Click()
Dim strWB As String, strFile As String
Application.ScreenUpdating = False
Application.EnableEvents = False
' Name of this workbook
strWB = ThisWorkbook.Name
' Recuperation of the 1st workbook of the directory
strFile = Dir("D:\testlist\CMV42" & "\*.html")
' Loop between the 1st and last workbook
Do While strFile <> ""
chemin = "D:\testlist\CMV42" & "\" & strFile
Set Objet = CreateObject("Scripting.FileSystemObject")
Set Fichier = Objet.GetFile(chemin)
' If the name of the workbook doesnt exists in column C
If Fichier.DateLastModified >= UserGuide!I1 And Fichier.DateLastModified <= UserGuide!J1 Then
ElseIf strFile <> strWB And Worksheets("Calcul2").Columns("C").Find(strFile, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
' Open Workbook
Workbooks.Open "D:\testlist\CMV42" & "\" & strFile
' Datas copy
Workbooks(strFile).Worksheets(1).Range("A11:C28").Copy
With Workbooks(strWB).Worksheets("Calcul2")
.Range("A2").Insert xlDown 'insertion en ligne 2
.Range("c2:c19").ClearContents 'on ne garde que les données A2:B17
.Range("C3") = strFile
.Range("C2") = Fichier.DateLastModified
End With
' Close Workbook
Workbooks(strFile).Close
End If
' Next Workbook
strFile = Dir
Loop
' Next Directory
' Recuperation of the 1st workbook of the directory
strFile = Dir("D:\testlist\CMV01" & "\*.html")
' Loop between the 1st and last workbook
Do While strFile <> ""
chemin = "D:\testlist\CMV01" & "\" & strFile
Set Objet = CreateObject("Scripting.FileSystemObject")
Set Fichier = Objet.GetFile(chemin)
' If the name of the workbook doesnt exists in column C
If Fichier.DateLastModified >= UserGuide!I1 And Fichier.DateLastModified <= UserGuide!J1 Then
ElseIf strFile <> strWB And Worksheets("Calcul2").Columns("C").Find(strFile, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
' Open Workbook
Workbooks.Open "D:\testlist\CMV01" & "\" & strFile
' Datas copy
Workbooks(strFile).Worksheets(1).Range("A11:C28").Copy
With Workbooks(strWB).Worksheets("Calcul2")
.Range("A2").Insert xlDown 'insertion en ligne 2
.Range("c2:c19").ClearContents 'on ne garde que les données A2:B17
.Range("C3") = strFile
.Range("C2") = Fichier.DateLastModified
End With
' Close Workbook
Workbooks(strFile).Close
End If
' Next Workbook
strFile = Dir
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Le traitement des fichiers est terminé.", vbInformation, "Traitement..."
End Sub