Recherche fichier dans dossier et sous dossier
Bonjour,
J'essaye de trouver un code qu'il me permette de trouver un fichier intitulé (Test.xls) dans un dossier avec ses sous dossiers.
Le code ci-après recherche le fichier "Test.xls" uniquement dans le dossier intitulé "A - Audits". Mais ce dossier "A - Audits" contient d'autres sous-dossiers, et j'aimerai que la recherche se fasse dans ces sous-dossiers sans modifier le chemin mentionné dans la macro à savoir : chemin = "G:\S - ISO\A - Audits\".
Est-ce possible ?
Private Sub CommandButton1_Click()
Dim Wb As Workbook
Feuil1.Select 'Feuil1(nom de gauche en projet)
chemin = "G:\S - ISO\A - Audits\"
fichier = TextBox1.Text & ".xls"
On Error Resume Next
Set Wb = GetObject(chemin & fichier)
If Err <> 0 Then MsgBox "Fichier Absent": Exit Sub
Bonjour thomasdu40,
Etant donné que tu es sur excel 2002, utilise le complément FileSearch comme ceci :
Private Sub CommandButton1_Click()
Dim nomFichier As String, i As Long, cpt As Long
nomFichier = TextBox1.Text 'nom du fichier à chercher
With Application.FileSearch
.NewSearch
.LookIn = "G:\S - ISO\A - Audits\" 'on regarde dans ce répertoire
.SearchSubFolders = True 'on regarde dans les sous-dossiers également
.Filename = nomFichier 'nom du fichier à chercher
.MatchTextExactly = True 'on cherche dans les fichiers qui contiennent le nom du fichier cherché
.FileType = msoFileTypeExcelWorkbooks 'on cherche que les classeur excel
If .Execute() > 0 Then 'si un fichier est trouvé
For i = 1 To .FoundFiles.Count 'on boucle sur tous les fichiers comportant le nom du fichier
If .FoundFiles(i) Like "*" & nomFichier & ".xls" Then 'si le fichier correspond exactement au nom recherché
cpt = cpt + 1 'on incrémente un compteur
End If
Next i
End If
If cpt > 0 Then
MsgBox "Il y a " & cpt & " " & IIf(cpt = 1, "fichier intitulé ", "fichiers intitulés ") & """" & nomFichier & """.", vbInformation
Else
MsgBox "Fichier Absent", vbExclamation
End If
End With
End Sub
Merci vba-new
ok j'ai intégré le code mais malheureusement si il trouve le fichier il ne m'extrait pas les données voici le code original complet. Celui-ci fonctionne hormis la recherche dans les sous-dossiers. Comment puis-je intégrer ton code correctement ?
Private Sub CommandButton1_Click()
Dim Wb As Workbook
Feuil1.Select 'Feuil1(nom de gauche en projet)
Chemin = "G:\S - ISO\A - Audits\"
Fichier = TextBox1.Text & ".xls"
On Error Resume Next
Set Wb = GetObject(Chemin & Fichier)
If Err <> 0 Then MsgBox "Fichier Absent": Exit Sub
With Wb.Sheets("ConstatsISO")
For k = 8 To .[A65536].End(3).Row
If .Range("A" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
Range("I" & lig).Value = .Range("A" & k).Value
Range("P" & lig).Value = .Range("B" & k).Value
Range("H" & lig).Value = .Range("C" & k).Value
Range("Q" & lig).Value = .Range("D" & k).Value
Range("R" & lig).Value = .Range("E" & k).Value
End If
Next
End With
With Wb.Sheets("ConstatsISO22000")
For k = 8 To .[A65536].End(3).Row
If .Range("A" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
Range("I" & lig).Value = .Range("A" & k).Value
Range("P" & lig).Value = .Range("B" & k).Value
Range("H" & lig).Value = .Range("C" & k).Value
Range("Q" & lig).Value = .Range("D" & k).Value
Range("R" & lig).Value = .Range("E" & k).Value
End If
Next
End With
With Wb.Sheets("ConstatsIFS")
For k = 6 To .[C65536].End(3).Row
If .Range("C" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
Range("I" & lig).Value = .Range("C" & k).Value
Range("P" & lig).Value = .Range("D" & k).Value
Range("H" & lig).Value = .Range("E" & k).Value
Range("Q" & lig).Value = .Range("B" & k).Value
Range("R" & lig).Value = .Range("F" & k).Value
End If
Next
End With
With Wb.Sheets("ConstatsBRC")
For k = 6 To .[C65536].End(3).Row
If .Range("C" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
Range("I" & lig).Value = .Range("C" & k).Value
Range("P" & lig).Value = .Range("D" & k).Value
Range("H" & lig).Value = .Range("E" & k).Value
Range("Q" & lig).Value = .Range("B" & k).Value
Range("R" & lig).Value = .Range("F" & k).Value
End If
Next
End With
With Wb.Sheets("ConstatsIFS_BRC")
For k = 6 To .[C65536].End(3).Row
If .Range("C" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
Range("I" & lig).Value = .Range("C" & k).Value
Range("P" & lig).Value = .Range("D" & k).Value
Range("H" & lig).Value = .Range("E" & k).Value
Range("Q" & lig).Value = .Range("B" & k).Value
Range("R" & lig).Value = .Range("F" & k).Value
End If
Next
End With
Wb.Close
End Sub
Re,
C'est vrai qu'avec le code complet c'est mieux !
Voici le code adapté :
Private Sub CommandButton1_Click()
Dim Wb As Workbook
Dim nomFichier As String, fichierAOuvrir As String
Dim i As Long, cpt As Long, k As Long, lig As Long
Feuil1.Select 'Feuil1(nom de gauche en projet)
nomFichier = TextBox1.Text
With Application.FileSearch
.NewSearch
.LookIn = "G:\S - ISO\A - Audits\" 'on regarde dans ce répertoire
.SearchSubFolders = True 'on regarde dans les sous-dossiers également
.Filename = nomFichier 'nom du fichier à chercher
.MatchTextExactly = False 'on cherche dans les fichiers qui contiennent le nom du fichier cherché
.FileType = msoFileTypeExcelWorkbooks 'on cherche que les classeur excel
If .Execute() > 0 Then 'si un fichier est trouvé
For i = 1 To .FoundFiles.Count 'on boucle sur tous les fichiers comportant le nom du fichier
If .FoundFiles(i) Like "*" & nomFichier & ".xls" Then 'si le fichier correspond exactement au nom recherché
fichierAOuvrir = .FoundFiles(i)
cpt = cpt + 1 'on incrémente un compteur
End If
Next i
End If
If cpt > 0 Then
MsgBox "Il y a " & cpt & " " & IIf(cpt = 1, "fichier intitulé ", "fichiers intitulés ") & """" & nomFichier & """.", vbInformation
Else
MsgBox "Fichier Absent", vbExclamation: Exit Sub
End If
End With
Workbooks.Open (fichierAOuvrir)
Set Wb = ActiveWorkbook
With Wb.Sheets("ConstatsISO")
For k = 8 To .[A65536].End(3).Row
If .Range("A" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
Range("I" & lig).Value = .Range("A" & k).Value
Range("P" & lig).Value = .Range("B" & k).Value
Range("H" & lig).Value = .Range("C" & k).Value
Range("Q" & lig).Value = .Range("D" & k).Value
Range("R" & lig).Value = .Range("E" & k).Value
End If
Next
End With
With Wb.Sheets("ConstatsISO22000")
For k = 8 To .[A65536].End(3).Row
If .Range("A" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
Range("I" & lig).Value = .Range("A" & k).Value
Range("P" & lig).Value = .Range("B" & k).Value
Range("H" & lig).Value = .Range("C" & k).Value
Range("Q" & lig).Value = .Range("D" & k).Value
Range("R" & lig).Value = .Range("E" & k).Value
End If
Next
End With
With Wb.Sheets("ConstatsIFS")
For k = 6 To .[C65536].End(3).Row
If .Range("C" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
Range("I" & lig).Value = .Range("C" & k).Value
Range("P" & lig).Value = .Range("D" & k).Value
Range("H" & lig).Value = .Range("E" & k).Value
Range("Q" & lig).Value = .Range("B" & k).Value
Range("R" & lig).Value = .Range("F" & k).Value
End If
Next
End With
With Wb.Sheets("ConstatsBRC")
For k = 6 To .[C65536].End(3).Row
If .Range("C" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
Range("I" & lig).Value = .Range("C" & k).Value
Range("P" & lig).Value = .Range("D" & k).Value
Range("H" & lig).Value = .Range("E" & k).Value
Range("Q" & lig).Value = .Range("B" & k).Value
Range("R" & lig).Value = .Range("F" & k).Value
End If
Next
End With
With Wb.Sheets("ConstatsIFS_BRC")
For k = 6 To .[C65536].End(3).Row
If .Range("C" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
Range("I" & lig).Value = .Range("C" & k).Value
Range("P" & lig).Value = .Range("D" & k).Value
Range("H" & lig).Value = .Range("E" & k).Value
Range("Q" & lig).Value = .Range("B" & k).Value
Range("R" & lig).Value = .Range("F" & k).Value
End If
Next
End With
Wb.Close
End Sub
Re,
Non il ne m'extrait pas les données comme il faudrait.
En gros, cette macro se trouve dans un fichier appelé "Plan d'action SMQ". En la faisant fonctionner elle va extraire les informations présentes dans le fichier recherché et issues des onglets "Constats..." pour les coller dans le "Plan d'action SMQ".
Avec ce code il me colle les données directement dans le fichier recherché.
Je ne savais pas comment marche ta macro ! Essaie comme ceci :
Private Sub CommandButton1_Click()
Dim WbPrincipal As Workbook, Wb As Workbook
Dim nomFichier As String, fichierAOuvrir As String
Dim i As Long, cpt As Long, k As Long, lig As Long
Set WbPrincipal = ActiveWorkbook
WbPrincipal.Feuil1.Select 'Feuil1(nom de gauche en projet)
nomFichier = TextBox1.Text
With Application.FileSearch
.NewSearch
.LookIn = "G:\S - ISO\A - Audits\" 'on regarde dans ce répertoire
.SearchSubFolders = True 'on regarde dans les sous-dossiers également
.Filename = nomFichier 'nom du fichier à chercher
.MatchTextExactly = False 'on cherche dans les fichiers qui contiennent le nom du fichier cherché
.FileType = msoFileTypeExcelWorkbooks 'on cherche que les classeur excel
If .Execute() > 0 Then 'si un fichier est trouvé
For i = 1 To .FoundFiles.Count 'on boucle sur tous les fichiers comportant le nom du fichier
If .FoundFiles(i) Like "*" & nomFichier & ".xls" Then 'si le fichier correspond exactement au nom recherché
fichierAOuvrir = .FoundFiles(i)
cpt = cpt + 1 'on incrémente un compteur
End If
Next i
End If
If cpt > 0 Then
MsgBox "Il y a " & cpt & " " & IIf(cpt = 1, "fichier intitulé ", "fichiers intitulés ") & """" & nomFichier & """.", vbInformation
Else
MsgBox "Fichier Absent", vbExclamation: Exit Sub
End If
End With
Workbooks.Open (fichierAOuvrir)
Set Wb = ActiveWorkbook
Windows(WbPrincipal.Name).Activate
WbPrincipal.Feuil1.Select 'Feuil1(nom de gauche en projet)
With Wb.Sheets("ConstatsISO")
For k = 8 To .[A65536].End(3).Row
If .Range("A" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
Range("I" & lig).Value = .Range("A" & k).Value
Range("P" & lig).Value = .Range("B" & k).Value
Range("H" & lig).Value = .Range("C" & k).Value
Range("Q" & lig).Value = .Range("D" & k).Value
Range("R" & lig).Value = .Range("E" & k).Value
End If
Next
End With
With Wb.Sheets("ConstatsISO22000")
For k = 8 To .[A65536].End(3).Row
If .Range("A" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
Range("I" & lig).Value = .Range("A" & k).Value
Range("P" & lig).Value = .Range("B" & k).Value
Range("H" & lig).Value = .Range("C" & k).Value
Range("Q" & lig).Value = .Range("D" & k).Value
Range("R" & lig).Value = .Range("E" & k).Value
End If
Next
End With
With Wb.Sheets("ConstatsIFS")
For k = 6 To .[C65536].End(3).Row
If .Range("C" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
Range("I" & lig).Value = .Range("C" & k).Value
Range("P" & lig).Value = .Range("D" & k).Value
Range("H" & lig).Value = .Range("E" & k).Value
Range("Q" & lig).Value = .Range("B" & k).Value
Range("R" & lig).Value = .Range("F" & k).Value
End If
Next
End With
With Wb.Sheets("ConstatsBRC")
For k = 6 To .[C65536].End(3).Row
If .Range("C" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
Range("I" & lig).Value = .Range("C" & k).Value
Range("P" & lig).Value = .Range("D" & k).Value
Range("H" & lig).Value = .Range("E" & k).Value
Range("Q" & lig).Value = .Range("B" & k).Value
Range("R" & lig).Value = .Range("F" & k).Value
End If
Next
End With
With Wb.Sheets("ConstatsIFS_BRC")
For k = 6 To .[C65536].End(3).Row
If .Range("C" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
Range("I" & lig).Value = .Range("C" & k).Value
Range("P" & lig).Value = .Range("D" & k).Value
Range("H" & lig).Value = .Range("E" & k).Value
Range("Q" & lig).Value = .Range("B" & k).Value
Range("R" & lig).Value = .Range("F" & k).Value
End If
Next
End With
Wb.Close False
End Sub
Merci à toi cette fois-ci tout fonctionne parfaitement.
Bonjour ce que je voudrais faire, c est un peu le meme principe.
Premièrement je suis sous Excel 2013.
J'ai un tableau avec des noms de pieces (du type PC96582) dans la colonne de gauche. Pour chaque pièces j'ai besoin d'aller chercher un dossier dans le fin fond de mon disque dur, de l'ouvrir et de copier les valeurs de la feuille " METHODES " de la cellule C4 à AV4, pour après les coller de la cellule Gi à ACi (j'ai mis "i" pour vous faire comprendre que à chaque fois que l'on change de pièce on descend d'un ligne.
Il faut savoir que le nom du fichier que je recherche commence toujours par " OP45_Tournage_ " et ce fini par le nom de la pièce.
Je cherche chaque fichier dans l'emplacement "E:\06-Dossier"
Je suis débutant dans le milieu, du coup je dispas non à un petit coup de pouce
Bonjour
Je n'ai jamais fait de maccro. Ce jour Jessai de trouver une solution pour aller rechercher un code dans le nom d'un fichier et qu'il m'en mette le lien. J'ai plus de 300 fichier à chercher et ceux chaque année du coup je me dis que via Excel y a peut être moyen de faire quelque chose sans perdre trop de temps à la main. Mais partant de 0 je cherche sur les forums je vois des choses intéressantes mais je n'arrive pas à les mettre en place.
Du coup j'en fait appel à votre aide.
Explications.
J'ai un tableau avec en colonne à des code article à 7 chiffres en B les libellé en C D E F G diverses info du produits. Et donc j'aimerais qu'en IJKLM... Il vienne me mettre le lien de la fiche.
Les fiches suivent un process de créa elles d'abord en créa ensuite en Ft.... Les colonnes IJKLM représentent donc ou en est la fiche.
Donc il me faudrait un code simple pour chercher le lien de la fiche dans un dossier et sous dossier sachant que le nom de la fiche contient le code article c'est Dailleur le début du nom de la fiches.
Je pense que si le premier code et fait je pourrais essayer de le copier pour le refaire sur les autres dossier.
En espérant avoir été claire, et que vous pourrez m'aider.
Merci d'avance.
Prenez soin de vous