Discussion :

[tequillaman]

Bonjour à tous,
Après un joli viaduc de repos, reprise de l'apprentissage de VB
J'ai lu pas mal de topic sur la recherche de fichier dans des dossiers et sous dossiers. J'ai ai extrait le code suivant (avec une partie du miens).
Mon besoins est le suivant. Je souhaite que me macro recherche un fichier qui se nomme en partie via le text box dans des dossiers et sous dossier.
J'ai un chemin type xxxxxxx\xxxxx\campage\ dans se dossier, j'ai des sous dossiers en fonction de l'année et à l'interieur des sous dossiers en fonction de la semaine.
ex xxxx\xxxx\campagne\2016\S15\fichier a trouver
Je voudrais que ma macro qui met à jour un tableau recherche dans les dossiers et sous dossiers de l'année N-1 et N mon fichier demandé dans le textbox.
La partie du code que j'ai trouvé provoque une erreur à cause du filesearch car je suis sous 2007. J'ai trouvé des articles qui me dit de télécharger un complément ClasseFileSearch mais je en peu pas dans l'entreprise à cause des verroux de proxy.
Auriez-vous une autre piste?
Est-ce possible si je sauvegarde le fichier macro en .xls.

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
Private Sub Valider_Click()
    Dim CHE As String
    Dim FIC As String
    Dim REC1 As Range
    Dim name As String       'pour accepter le champs de saisie dans le userform
    Dim wbk2 As Workbook    ' pour fermer le classeur à la fin
 
    name = EVERTZ.saisie.Text
 
 
    'FIC = Dir(CHE & "\" & name & "*")
 
    ' vérification de la présence de la coulée dans le tableau de récupération
    Set REC1 = Range("A1:A65000").Find(name, lookat:=xlWhole)
 
    If REC1 Is Nothing Then    'si coulée non trouvée
        MsgBox ("Veillez importer les données de contrôle avant les données EVERTZ")
 
    Else
 
 
 
Static s As Integer
Dim repertoire()
'Detecter les repertoires
 
CHE = "E:\UL_EVERTZ\Suivi MAM et réparations\Campagne\"
myname = Dir(CHE, vbDirectory)
Do While myname <> ""
    If myname <> "." And myname <> ".." And myname <> "..." Then
        If (GetAttr(CHE & myname) And vbDirectory) = vbDirectory Then
            Debug.Print myname
            ReDim Preserve repertoire(s)
            repertoire(s) = CHE & myname
            s = s + 1
        End If
    End If
    myname = Dir
Loop
 
'Lister les fichier des repertoires
For g = 0 To s - 1
MsgBox repertoire(g)
Set fs = Application.FileSearch
With fs
    .LookIn = repertoire(g)
    .Filename = "*.*"
    .Execute
        For i = 1 To .FoundFiles.Count
            MsgBox .FoundFiles(i) 'intégrer le code d'apres à la place
        Next i
        If .FoundFiles.Count = 0 Then
        MsgBox "fichier non trouvé"
        End If
End With
Next

[joe.levrai]

Bonjour,

je te conseilles d'utiliser les objets FSO (File Scripting Object) qui permettent de parcourir les dossiers, sous-dossiers, fichiers etc...

fait une recherche sur le forum, il y a des centaines de sujets, ainsi que des tutos pour apprendre à manipuler.

voici pour commencer : http://warin.developpez.com/access/fichiers/

[tequillaman]

Merci joe
Il me reste un petit problème:
La recherche se fait bien, l'ouverture du fichier aussi, la copie des cellules également
le problème c'est qu'il ne me "colle" pas les cellules dans mon fichier et me met le msgbox err je ne comprends pas pourquoi
je vous joint le code

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
Sub Explorer(p_strFichier As String, p_strCheminDepart As String, Optional p_oFld As Scripting.Folder)
On Error GoTo err
    Dim oFSO As Scripting.FileSystemObject
    Dim oFld As Scripting.Folder
    Dim oFl As File
    Dim wbk2 As Workbook
 
    If p_oFld Is Nothing Then
        'Instanciation du FSO
        Set oFSO = New Scripting.FileSystemObject
        'Accède au répertoire du départ de recherche
        Set p_oFld = oFSO.GetFolder(p_strCheminDepart)
    End If
    Set oFl = p_oFld.Files(p_strFichier)
    MsgBox oFl.Path
    'ouverture du fichier
    Workbooks.Open Filename:=oFl.Path
    EVERTZ.Hide
    'copie
    Set wbk2 = ActiveWorkbook       'nommer wbk2 avec le nom du fichier ouvert
            Sheets("base récup").Select          ' choisir la feuille base recup
            ' copie
            Range("A2:B2").Copy
            Windows("Base de données.xls").Activate  ' revenir dans le classeur dans lequel copier les données
 
 
            'selectionne la cellule où copier
            Range(REC1, REC1.End(xlToLeft)).Select
            ActiveCell.Offset(0, 29).Select
            'colle
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
 
            wbk2.Close False 'fermer classeur wbk2
            'ajouter une autre coulée?
            nouvelajout.Show
 
 
 
SubDir:
'Explore les sous-dossiers
    For Each oFld In p_oFld.SubFolders
        Explorer p_strFichier, p_strCheminDepart, oFld
        DoEvents
    Next oFld
 
fin:
    Exit Sub
err:
    Select Case err.Number
        Case 53: Resume SubDir
        Case Else:
            MsgBox "Erreur inconnue"
            Resume fin
    End Select
 
End Sub
 
Private Sub Valider_Click()
    Dim CHE As String
    Dim REC1 As Range
    Dim name As String       'pour accepter le champs de saisie dans le userform
    Dim FICEVERTZ As String
 
    name = EVERTZ.saisie.Text
    FICEVERTZ = name & ".xls"
 
 
    ' vérification de la présence de la coulée dans le tableau de récupération
    Set REC1 = Range("A1:A65000").Find(name, lookat:=xlWhole)
 
    If REC1 Is Nothing Then    'si coulée non trouvée
        MsgBox ("Veillez importer les données de contrôle avant les données EVERTZ")
 
    Else
 
 
        Explorer FICEVERTZ, "E:\UL_EVERTZ\Suivi MAM et réparations\Campagne\"
 
    End If
End Sub

[joe.levrai]

Ta variable REC1 a une portée qui ne dépasse pas la procédure où elle est déclarée :

Code :

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

1
2
3
Private Sub Valider_Click()
    Dim CHE As String
    Dim REC1 As Range

tu tentes de la réutiliser dans une autre procédure :

Code :

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

1
2
3
4
Sub Explorer(p_strFichier As String, p_strCheminDepart As String, Optional p_oFld As Scripting.Folder)
'[...]
 'selectionne la cellule où copier
            Range(REC1, REC1.End(xlToLeft)).Select

je ne sais pas si c'est le seul problème, déclare déjà ta variable en public sur le module, et contrôle en pas à pas si tout se déroule mieux.


Y'a ensuite un gros travail de simplification à faire ... il est inutile de sélectionner et activer des objets pour les utiliser. Au contraire, c'est source d'ennuis futurs.
De même, ta gestion d'erreur, bien que louable, n'est pas assez complète :

- dans ton case Else, il est toujours opportun de renvoyer le numéro d'erreur et sa description (Err.Number et Err.Description) plutôt que de simplement dire "Erreur inconnue". Ca aide grandement à débugguer

- évite d'utiliser le mot "err" pour identifier ton bloc de gestion de l'erreur : err est un mot réservé qui renvoie aux objets erreurs d'execution


Mais pour le moment corrigeons déjà les problèmes qui se présentent

[tequillaman]

Effectivement, c'était bien la variable que je n'avais pas bien déclarée

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
Public REC1 As Range
 
 
 
Sub Explorer(p_strFichier As String, p_strCheminDepart As String, Optional p_oFld As Scripting.Folder)
On Error GoTo err
    Dim oFSO As Scripting.FileSystemObject
    Dim oFld As Scripting.Folder
    Dim oFl As File
    Dim wbk2 As Workbook
 
    If p_oFld Is Nothing Then
        'Instanciation du FSO
        Set oFSO = New Scripting.FileSystemObject
        'Accède au répertoire du départ de recherche
        Set p_oFld = oFSO.GetFolder(p_strCheminDepart)
    End If
    Set oFl = p_oFld.Files(p_strFichier)
    'MsgBox oFl.Path affiche le chemin du fichier
    'ouverture du fichier
    Workbooks.Open Filename:=oFl.Path
    'copie
    Set wbk2 = ActiveWorkbook       'nommer wbk2 avec le nom du fichier ouvert
            Sheets("base récup").Select          ' choisir la feuille base recup
            ' copie
            Range("A2:B2").Copy
            Windows("Base de données.xls").Activate  ' revenir dans le classeur dans lequel copier les données
 
 
            'selectionne la cellule où copier
            Range(REC1, REC1.End(xlToLeft)).Select
            ActiveCell.Offset(0, 34).Select
            'colle
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
 
            wbk2.Close False 'fermer classeur wbk2
            'ajouter une autre coulée?
            nouvelajout.Show
 
 
 
SubDir:
'Explore les sous-dossiers
    For Each oFld In p_oFld.SubFolders
        Explorer p_strFichier, p_strCheminDepart, oFld
        DoEvents
    Next oFld
 
fin:
    Exit Sub
err:
    Select Case err.Number
        Case 53: Resume SubDir
        Case Else:
            MsgBox "Erreur inconnue"
            Resume fin
    End Select
 
End Sub
 
Private Sub Valider_Click()
    Dim name As String       'pour accepter le champs de saisie dans le userform
    Dim FICEVERTZ As String
 
    name = EVERTZ.saisie.Text
    FICEVERTZ = name & ".xls"
 
    Windows("Base de données.xls").Activate
    ' vérification de la présence de la coulée dans le tableau de récupération
    Set REC1 = Range("A1:A65000").Find(name, lookat:=xlWhole)
 
    If REC1 Is Nothing Then    'si coulée non trouvée
        MsgBox ("Veillez importer les données de contrôle avant les données EVERTZ")
 
    Else
 
 
        Explorer FICEVERTZ, "E:\UL_EVERTZ\Suivi MAM et réparations\Campagne\"
 
    End If
End Sub

Tu me parlais de simplifier le code. de quelle manière?
Saurais-tu où mettre un msgbox si le fichier n'existe pas?

[joe.levrai]

Bonjour,

je ne suis pas sûr de bien saisir ce que tu veux faire.

tu parcours une arborescence complète pour rechercher un fichier qui peut exister plusieurs fois ou non ?
à moins qu'il faille trouver un unique fichier mais on ne sait pas dans quel dossier ?
je penche pour le fichier unique, au vu de la manière dont tu colles les valeurs (s'il y avait plusieurs fichiers les valeurs s'écraseraient à chaque fois)


voici une proposition sans gestion complexe des erreurs. Attention car je l'ai écrite à main levée et pas testée, il y a probablement quelques ajustements à faire
L'idée concerne surtout la structure de ton traitement, on décompose le traitement en plusieurs étapes, en s'aidant de deux variables publiques :

Code :

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

1
2
Public FichierTrouve As Boolean
Public Plage As Range

1) Collecter les données d'entrée (dossier de départ, nom du fichier, la plage Excel qui contient le nom 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
Private Sub Valider_Click()
Dim Chemin As String
Dim NomFich As String
    Chemin = "E:\UL_EVERTZ\Suivi MAM et réparations\Campagne\"
    NomFich = evertz.saisie.Text & ".xls"
 
    ' vérification de la présence de la coulée dans le tableau de récupération
    Set Plage = Sheets("Base de données.xls").Range("A1:A65000").Find(NomFich, lookat:=xlWhole)
 
    If Plage Is Nothing Then    'si coulée non trouvée
        MsgBox ("Veuillez importer les données de contrôle avant les données EVERTZ")
    Else
        Explorer NomFich, Chemin
 
        If Not FichierTrouve Then MsgBox "Le Fichier suivant n'a pas été trouvé : " & NomFich
        'ajouter une autre coulée?
        nouvelajout.Show
    End If
End Sub

2) parcourir chaque dossier de l'arborescence

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
Sub Explorer(p_strFichier As String, p_strCheminDepart As String, Optional p_oFld As Scripting.folder)
Dim oFSO As Scripting.FileSystemObject
Dim oFld As Scripting.folder
Dim oFl As File
 
    If p_oFld Is Nothing Then
        'Instanciation du FSO
        Set oFSO = New Scripting.FileSystemObject
        On Error Resume Next
            Set p_oFld = oFSO.GetFolder(p_strCheminDepart)
        On Error GoTo 0
 
        If p_oFld Is Nothing Then
            MsgBox "Le dossier racine est introuvable : " & vbCrLf & p_strCheminDepart
            Exit Sub
        End If
    End If
 
    ' récursion pour parcourir l'ensemble de l'arborescence
    For Each oFld In p_oFld.SubFolders
        If Not FichierTrouve Then
            Explorer p_strFichier, p_strCheminDepart, oFld
            DoEvents
        End If
    Next oFld
End Sub

3) Chercher le fichier dans le dossier (là on peut utiliser la fonction Dir() plutôt que du FSO ...)

Code :

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

1
2
3
4
5
6
7
8
9
10
11
Sub ChercheFichier(NomFichier As String, DossierRecherche As Scripting.folder)
Dim LeFichier As Scripting.File
    On Error Resume Next
        Set LeFichier = DossierRecherche.Files(NomFichier)
    On Error GoTo 0
 
    If Not LeFichier Is Nothing Then
        CopieDonnees (LeFichier.Path)
        FichierTrouve = True
    End If
End Sub

4) copier les données

Code :

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

1
2
3
4
5
6
Sub CopieDonnees(CheminFichier As String)
    With Workbooks.Open(CheminFichier)
        .Sheets("base récup").Range("A2:B2").Copy Plage.Offset(0, 34)
        .Close False
    End With
End Sub