XL 2019 Rechercher un fichier dans plusieurs répertoires

[qalibo30]

Bonjour à tous,
J'espère que vous allez bien malgré les évènements.
Voilà j'ai recherché dans les discussions sur le site une solution à ma recherche mais en vain.

Dans un fichier EXCEL, j'ai dans la colonne A, des noms dans les différentes cellules, qui correspondent à des noms de fichiers qui peuvent se trouver
dans des répertoires ou sous-répertoires différents sous C:\ (mais ca pourrait être dans tout autre disque)
Je souhaiterai en cliquant sur une cellule de la colonne A, que le fichier qui a le même nom et qui se trouve donc dans un autre répertoire ou sous répertoire puisse s'ouvrir.

J'ai mis le fichier en questione en pièce jointe dans lequel il y dans Feuil1, une macro qui fonctionne mais seulement si le chemin de recherche est stipulé (ex: chemin = "C:\Perso\Administratif\")

J'ai trouvé 2 exemples (Sub FileSearch() et Sub FileSearch2()) d'utilisation de "SearchSubFolders" que j'ai copié dans le Module 1 mais malgré mes tentatives, il y a un soucis avec l'utilisation de With Application.FileSearch


Merci pour votre aide.

 

[qalibo30]

J'avoue que je ne suis pas de ta pointure et très loin de là!!
Je souhaiterai juste pouvoir ouvrir le fichier correspondant au nom dans la cellule en double cliquant dessus.
J'ai essayé de manipuler ton code mais je n'y suis pas arrivé
Il faudrait mettre un bout de code du genre

Set classeur = Workbooks.Open(itemVU) ? mais avant ou après quoi..

 

[patricktoulon]

colle tout dans le module de la Feuil1

doubleclick sur cellule pour ouvrir le fichier

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Column = 1 And Target.Count = 1 And Target.Value <> Empty Then
        maliste = liste_mes_Fichiers("C:\Résultats\")  ' EXTENTION DEMANDE
        For l = LBound(maliste) To UBound(maliste)
            If maliste(l) Like "*" & Target.Text & ".*" Then
            Set wbk = Workbooks.Open(maliste(l)): Exit For
        End If
        Next
    End If
End Sub
Function liste_mes_Fichiers(path As String, Optional T As Variant = Null, Optional ExT As Variant = 0, Optional a As Long = 0)
    Dim itemVU As String, folder As Variant, dirCollection As Collection, i As Long
    Set dirCollection = New Collection
    If IsNull(T) Then T = Array()
    crit = vbDirectory Or vbHidden Or vbNormal Or vbArchive Or vbReadOnly Or vbSystem Or vbVolume
    On Error GoTo passe
    itemVU = Dir(path, crit)
      Do Until itemVU = vbNullString
        If Left(itemVU, 1) <> "." And Not path Like "*RECYCLE*" Then
            If (GetAttr(path & itemVU) And vbDirectory) <> vbDirectory Then
                 If IsArray(ExT) Then
                    For i = 0 To UBound(ExT)
                        If itemVU Like "*" & ExT(i) Then
                            ReDim Preserve T(0 To a): T(a) = path & itemVU: a = a + 1:
                        End If
                    Next
                Else
                    ReDim Preserve T(0 To a): T(a) = path & itemVU: a = a + 1:
                End If
            End If
        End If
        'ajout des dossiers enfant direct de la racine a la collection
        If Left(itemVU, 1) <> "." And (GetAttr(path & itemVU) And vbDirectory) = vbDirectory Then
            dirCollection.Add itemVU
        End If
        itemVU = Dir()
    Loop
passe:
    Err.Clear
    'Exploration des subdossier inscrit dans la collection
    For Each folder In dirCollection
          liste_mes_Fichiers path & folder & "\", T, ExT, a
    Next folder
    liste_mes_Fichiers = T
End Function

 

[qalibo30]

Il ne se passe rien

 

[qalibo30]

Désolé, je n'avais pas changé le chemin, ca fonctionne parfaitement, un grand merci à toi !!!!

 

[patricktoulon]

alors tu a oublié de donner des indications j'ai testé chez moi ça fonctionne
si tes fichier sont bien dans "C:\Résultas\" dans des sous dossiers ca devrait fonctionner sauf si windows t'en empêche en mode non administrateur j'ai vu ca sur certains pc
au quel cas laisse tomber, c'est la croix et la bananière surtout avec w10

 

[patricktoulon]

Ah !! à la bonne heure

 

[patricktoulon]

après sincèrement le disk "C" n'est pas meilleur endroit ou placer des dossiers perso

 

[qalibo30]

Non non, je t'ai répondu il y a 10 minutes environ. J'avais effectivement changé le nom du chemin, je voulais tester en déposant le répertoire des fichiers ailleurs pour confirmer. Et ca marche du tonnerre donc encore une fois un grand merci pour ton aide précieuse. Bonne soirée et une belle semaine.

 

[qalibo30]

Oui je sais mais c'était pour tester, en fait ces dossiers seront déposés sur le réseau Merci!!!!

 

[kiki29]

Salut, via les APIs à voir, élaguer etc, bref adapter à ton contexte

Fichier corrigé le 03 Mai 2020. Merci à Fanch55

 

[fanch55]

For l = LBound(maliste) To UBound(maliste) If maliste(l) Like "*" & Target.Text & ".*" Then Set wbk = Workbooks.Open(maliste(l)): Exit For End If

Testé chez moi: surpris de voir qu'excel savait ouvrir un fichier Gif en mode tableur ...

Je devines bien que c'est un exemple vite fait mais il faut que @qalibo30 l'adapte car
comment faire la différence entre un fichier "03246779" et "Dudule79" si on entre 79 ?

Et je suis d'accord, le disque C: devrait rester un disque uniquement système surtout si c'est un SSD .

 

[patricktoulon]

Bonjour fanch55
oui c'est vrai j'ai pas mis l’/ les extension qui sont possible
deja on remet les extensions désirées
maliste = liste_mes_Fichiers("C:\Résultats\",".xls",".xlsx",".xlsm") ' EXTENTION DEMANDE
je peux ajouter un argument de plus "fichier" avec le nom en cellule et y ajouter un like

 

[jmfmarques]

Re bonjour à tous

Mon opinion reste la même en ce qui concerne ce que j'ai dit plus haut. Les démarches de l'espèce dénotent un défaut de conception et peuvent générer des situations très gênantes. Dire qu'il n'y a pas de doublons à un instant t est "un peu" acceptable. Dire qu'il n'y en aura JAMAIS (du fait, entre autres, de l'utilisateur final) est plutôt "aventureux"

Nonobstant : si donc, l'on part du principe selon lequel il n'y aura assurément (!!!) jamais de doublons , la démarche ne doit alors pas être du type que vous avez choisi (parcours et recensement par la fonction dir), mais du type de celle choisie par Microsoft (pour tenter par exemple de trouver le nouveau chemin réel d'un raccourci). Démarche autrement légère et agile, mais qui n'affranchit pas non plus des dangers que je tiens à pointer du doit.

 

[jmfmarques]

Pour les curieux et sans atténuer ma mise en garde, voici (exemple) ce qu'utilise Microsoft dans certains cas :

Private Declare Function SearchTreeForFile Lib "imagehlp" (ByVal RootPath As String, ByVal InputPathName As String, ByVal OutputPathBuffer As String) As Long
Private Const MAX_PATH = 260

Private Sub Commandbutton1_Click()
 Dim repertoire As String, fichier As String
 repertoire = "C:\"
 fichier = "vache.JPG"
 MsgBox trouve(repertoire, fichier)
End Sub

Private Function trouve(R As String, F As String) As String
  Dim T As String, resu As Long
  T = String(MAX_PATH, 0)
  resu = SearchTreeForFile(R, F, T)
  If resu <> 0 Then
    trouve = Left$(T, InStr(1, T, Chr$(0)) - 1): Exit Function
  End If
End Function

 

[patricktoulon]

re
tiens dans mes archives vbs j'en ai retrouvé une que j'ai adapté vba
cette fois si la fonction quand le fichier est trouvé fait les tours recursif pré lancés a blanc et s'arrete donc au if
elle ne renvoie plus un tableau mais le string du chemin

bon c'est FSO

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim MyFich$
    If Target.Column = 1 And Target.Count = 1 And Target.Value <> Empty Then
        MyFich = recherche_récursive("C:\Résultats\", PartName:=Target.Text)    ' EXTENTION DEMANDE
        If MyFich <> "" Then Workbooks.Open (MyFich)
    End If
End Sub    '
'
Private Function recherche_récursive(dparent, Optional res As String, Optional PartName As String = "") As Variant
    Dim FSO As Object, Lparent As Object, SubFolder As Object, Ficher
    Set FSO = CreateObject("scripting.filesystemobject")

    'la fonction étant récursive pour éviter le reste de l’exécution du code si trouvé
    If PartName <> "" Then If res Like PartName & ".*" Then Exit Function

    Set Lparent = FSO.GetFolder(dparent)
    If GetAttr(Lparent) <> 22 Then
        On Error GoTo passe
        For Each Ficher In Lparent.Files    'on boucle sur les fichiers qui sont dans ce dossier
            res = res & Ficher & vbCrLf
            Debug.Print Ficher
            If PartName <> "" Then If Ficher Like "*" & PartName & "*.*" Then res = Ficher: Exit For
        Next
passe:
        Err.Clear
        'boucles sur les sous dossiers
        If Not res Like PartName & ".*" Then ' si trouver on cherche plus dans les subfolder
            For Each SubFolder In Lparent.SubFolders    'on boucle sur les dossiers qui sont dans ce dossiers
                Debug.Print SubFolder
                recherche_récursive SubFolder.Path, res, PartName  ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que l'extension et res qui est déjà peut être remplie
            Next SubFolder
        End If
    End If
    recherche_récursive = res
End Function

jacques je regarde ton truc