Discussion :

[thomasdu40]

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 ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
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

[tarnx]

A-tu essayé de te pencher sur la méthode FileSearch?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
With Application.FileSearch
    .LookIn = TonChemin
    .SearchSubFolders = True 'Recherche dans les sous-répertoires
    .Execute
End With

Et ensuite tu parcours la collection .FoundFiles

[thomasdu40]

Je ne pense pas que je puisse l'intégrer dans ma macro, en tout cas je n'y arrive pas.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
rivate 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

[Didier Gonard]

A-tu essayé de te pencher sur la méthode FileSearch?

Attention FileSearch est incompatible avec les versions 2007 et +.

Il est donc à éviter depuis...

thomasdu40

D'où l'intérêt de mettre la version concernée dans le titre de son message

cordialement,

Didier

[thomasdu40]

Excel 2002

[Didier Gonard]

bonjour,

dans le cas de l'utilisation de FileSearch sur des versions anciennes et dans une démarche raisonnée, il faut impérativement :

- Le signaler de façon visible dans son code

- mettre un filtre dans le WorkBook Open pour interdire l'ouverture sur des versions au-delà de 2003.

il était déjà en conflit avec le service d’indexation de l’explorateur sous 2003, je ne sais pas sous 2002 ?


voir ce lien dans la FAQ pour détourner le problème



cordialement,

Didier

[thomasdu40]

Bonjour le forum,

Je reprends ce post car je ne l'avais pas clôturé car ma version d'Excel va changer et passer à 2010. J'ai le code ci-dessous qui va rechercher dans le dossier voulu or le problème c'est que je souhaite qu'il recherche dans tous les sous-dossiers du dossier A-Audit. Je ne veux plus mettre le chemin complet.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Private Sub CommandButton1_Click()
Dim Wb As Workbook
Feuil2.Select  'Feuil2(nom de gauche en projet)
chemin = "G:\S - ISO\A - Audits\C - Audits internes et fournisseurs\"
fichier = TextBox1.Text & ".xls"
On Error Resume Next
Set Wb = GetObject(chemin & fichier)
If Err <> 0 Then MsgBox "Fichier Absent": Exit Sub

je sais que FileSearch ne fonctionnera pas avec Excel 2010. Malgré tous les posts que j'ai pu lire là je suis complètement perdu car je n'arrive pas à rédiger le code.

Si quelqu'un pouvait m'aider. D'avance merci.

[casefayere]

Bonjour,
tu peux adapter ce fichier :

[thomasdu40]

Bonjour,

J'en appelle à votre aide car après avoir planché tout ce week end et ce matin, je n'ai pu adapter une partie du code vba ci-après

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Private Function FindFile(ByVal sFol As String, sFile As String, _
   nDirs As Long, nFiles As Long) As Currency
   Dim tFld As Folder, tFil As File, FileName As String
 
   On Error GoTo Catch
   Set fld = fso.GetFolder(sFol)
   FileName = Dir(fso.BuildPath(fld.Path, sFile), vbNormal Or _
                  vbHidden Or vbSystem Or vbReadOnly)
   While Len(FileName) <> 0
      FindFile = FindFile + FileLen(fso.BuildPath(fld.Path, _
      FileName))
      nFiles = nFiles + 1
      ListBox1.AddItem fso.BuildPath(fld.ShortPath, FileName)  ' a adapter
      'ou ListBox1.AddItem  FileName
      FileName = Dir()  ' Get next file
      DoEvents
   Wend
   Label1 = "Recherche " & vbCrLf & fld.Path & "..."
   nDirs = nDirs + 1
      Exit Function
Catch:  FileName = ""
       Resume Next
End Function
Private Sub CommandButton1_Click()
 Dim nDirs As Long, nFiles As Long, lSize As Currency
   Dim sDir As String, sSrchString As String
   sDir = InputBox("Repertoire de départ", _
                   "Vous pouvez modifier", ThisWorkbook.Path)
   sSrchString = InputBox(" ", _
                   "Recherche et Ajout" & ".xls")
   Label1.Caption = "Recherche " & vbCrLf & UCase(sDir) & "..."
   lSize = FindFile(sDir, sSrchString, nDirs, nFiles)
   MsgBox Str(nFiles) & " Fichiers trouvés dans" & Str(nDirs) & _
          " repertoire(s)", vbInformation
  End Sub

avec le code suivant :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
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("ConstatsISO9001")
For k = 8 To .[A65536].End(3).Row
If .Range("A" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("H" & lig).Value = .Range("A" & k).Value
Range("F" & lig).Value = .Range("B" & k).Value
Range("G" & lig).Value = .Range("D" & k).Value
Range("I" & 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("H" & lig).Value = .Range("A" & k).Value
Range("F" & lig).Value = .Range("B" & k).Value
Range("G" & lig).Value = .Range("D" & k).Value
Range("I" & 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("H" & lig).Value = .Range("C" & k).Value
Range("F" & lig).Value = .Range("D" & k).Value
Range("G" & lig).Value = .Range("B" & k).Value
Range("I" & 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("H" & lig).Value = .Range("C" & k).Value
Range("F" & lig).Value = .Range("D" & k).Value
Range("G" & lig).Value = .Range("B" & k).Value
Range("I" & 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("H" & lig).Value = .Range("C" & k).Value
Range("F" & lig).Value = .Range("D" & k).Value
Range("G" & lig).Value = .Range("B" & k).Value
Range("I" & lig).Value = .Range("F" & k).Value
End If
Next
End With
Wb.Close
End Sub

La recherche se fait toujours sur un fichier .xls.

Merci.

[kiki29]

Salut, à voir en élaguant et adaptant http://www.developpez.net/forums/d20...feuille-excel/

[Theze]

Bonjour,

Une piste, résultat en A1 (chemin complet du fichier) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
 
Sub Test()
 
    Chemin "D:\", "Test.xls"
 
End Sub
 
Private Sub Chemin(Dossier As String, FichierCherche As String)
 
    Dim Fso As Object
    Dim Dos As Object
    Dim SousDos As Object
    Dim D As Object
    Dim Fichier As Object
 
    Set Fso = CreateObject("Scripting.FileSystemObject")
 
    'si le dossier n'existe pas, fin
    If Fso.FolderExists(Dossier) = False Then Exit Sub
 
    Set Dos = Fso.GetFolder(Dossier)
 
    'recherche le fichier dans le dossier
    For Each Fichier In Dos.Files
 
        'si trouvé, chemin en A1
        If InStr(Fichier, FichierCherche) <> 0 Then
 
            Range("A1") = Fichier.Path
 
        End If
 
    Next Fichier
 
    Set SousDos = Dos.SubFolders
 
    'recherche dans les sous dossiers
    For Each D In SousDos
 
        For Each Fichier In D.Files
 
            'évite l'erreur des dossiers interdits
            On Error Resume Next
 
            'si trouvé, chemin en A1
            If InStr(Fichier, FichierCherche) <> 0 Then
 
                Range("A1") = Fichier.Path
 
            End If
 
        Next Fichier
 
        'rappel de la proc pour chercher les
        'dossiers enfants
        Chemin D.Path, FichierCherche
 
    Next D
 
End Sub

Hervé.

[thomasdu40]

Bonjour Theze,

Merci. J'ai testé et en A1 le chemin d'accès complet s'affiche correctement sauf qu'il faut que j'indique le nom du fichier dans le code.

Par contre la 2ème partie pourrait répondre à mes attentes dans ce cas il fautdrait pouvoir l'intégrer au code ci-après. Tout le problème est là.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
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("ConstatsISO9001")
For k = 8 To .[A65536].End(3).Row
If .Range("A" & k) <> "" Then
lig = [I65536].End(3).Row + 1
Range("H" & lig).Value = .Range("A" & k).Value
Range("F" & lig).Value = .Range("B" & k).Value
Range("G" & lig).Value = .Range("D" & k).Value
Range("I" & 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("H" & lig).Value = .Range("A" & k).Value
Range("F" & lig).Value = .Range("B" & k).Value
Range("G" & lig).Value = .Range("D" & k).Value
Range("I" & 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("H" & lig).Value = .Range("C" & k).Value
Range("F" & lig).Value = .Range("D" & k).Value
Range("G" & lig).Value = .Range("B" & k).Value
Range("I" & 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("H" & lig).Value = .Range("C" & k).Value
Range("F" & lig).Value = .Range("D" & k).Value
Range("G" & lig).Value = .Range("B" & k).Value
Range("I" & 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("H" & lig).Value = .Range("C" & k).Value
Range("F" & lig).Value = .Range("D" & k).Value
Range("G" & lig).Value = .Range("B" & k).Value
Range("I" & lig).Value = .Range("F" & k).Value
End If
Next
End With
Wb.Close
End Sub

[Theze]

Bonjour,

Comme ceci ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
 
Dim NomFichier As String 'en tête de module
 
Sub Test()
 
    Dim Wb As Workbook
    Dim Fichier As String
    Dim K As Integer
    Dim Lig As Long
 
    Dim TextBox1
    Fichier = TextBox1.Text & ".xls"
 
    'adapter le lecteur
    Chemin "F:\", Fichier
 
    On Error Resume Next
 
    Set Wb = GetObject(NomFichier)
    'Set Wb = Workbooks.Open(NomFichier)<- pas plus adapté ?
 
    If Err <> 0 Then MsgBox "Fichier Absent !": Exit Sub
 
    With Wb.Sheets("ConstatsISO9001")
 
        For K = 8 To .[A65536].End(3).Row
 
            If .Range("A" & K) <> "" Then
 
                Lig = [I65536].End(3).Row + 1
                Range("H" & Lig).Value = .Range("A" & K).Value
                Range("F" & Lig).Value = .Range("B" & K).Value
                Range("G" & Lig).Value = .Range("D" & K).Value
                Range("I" & Lig).Value = .Range("E" & K).Value
 
            End If
 
        Next K
 
    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("H" & Lig).Value = .Range("A" & K).Value
                Range("F" & Lig).Value = .Range("B" & K).Value
                Range("G" & Lig).Value = .Range("D" & K).Value
                Range("I" & Lig).Value = .Range("E" & K).Value
 
            End If
 
        Next K
 
    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("H" & Lig).Value = .Range("C" & K).Value
                Range("F" & Lig).Value = .Range("D" & K).Value
                Range("G" & Lig).Value = .Range("B" & K).Value
                Range("I" & Lig).Value = .Range("F" & K).Value
 
            End If
 
        Next K
 
    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("H" & Lig).Value = .Range("C" & K).Value
                Range("F" & Lig).Value = .Range("D" & K).Value
                Range("G" & Lig).Value = .Range("B" & K).Value
                Range("I" & Lig).Value = .Range("F" & K).Value
 
            End If
 
        Next K
 
    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("H" & Lig).Value = .Range("C" & K).Value
                Range("F" & Lig).Value = .Range("D" & K).Value
                Range("G" & Lig).Value = .Range("B" & K).Value
                Range("I" & Lig).Value = .Range("F" & K).Value
 
            End If
 
        Next
 
    End With
 
    Wb.Close
 
End Sub
 
Private Sub Chemin(Dossier As String, _
                   FichierCherche As String)
 
    Dim Fso As Object
    Dim Dos As Object
    Dim SousDos As Object
    Dim D As Object
    Dim Fichier As Object
 
    Set Fso = CreateObject("Scripting.FileSystemObject")
 
    'si le dossier n'existe pas, fin
    If Fso.FolderExists(Dossier) = False Then Exit Sub
 
    Set Dos = Fso.GetFolder(Dossier)
 
    'recherche le fichier dans le dossier
    For Each Fichier In Dos.Files
 
        'si trouvé, chemin en A1
        If InStr(Fichier, FichierCherche) <> 0 Then
 
            NomFichier = Fichier.Path
 
        End If
 
    Next Fichier
 
    Set SousDos = Dos.SubFolders
 
    'recherche dans les sous dossiers
    For Each D In SousDos
 
        For Each Fichier In D.Files
 
            'évite l'erreur des dossiers interdits
            On Error Resume Next
 
            'si trouvé, chemin en A1
            If InStr(Fichier, FichierCherche) <> 0 Then
 
                NomFichier = Fichier.Path
 
            End If
 
        Next Fichier
 
        'rappel de la proc pour chercher les
        'dossiers enfants
        Chemin D.Path, FichierCherche
 
    Next D
 
End Sub

Hervé.