Recherche fichier sur hdd

Bonjour , je suis débutant sur VBA , et je souhaiterais créé une macro xl pour rechercher des fichiers sur le disque dur dont le nom incomplet serai inscrit dans une cellule.

Je voudrais aussi qu'une fois trouver ,le fichier s'ouvre avec l'application par défaut de windows.

Et si aucun fichier trouvé , un msgbox s'affiche pour nous le dire .

Je ne connais pas le chemin entier car les fichiers rechercher sont dans un dossier dans lequel il y a plusieurs sous dossier.
Je ne connais pas non plus le nom complet du fichier . Juste les 1er caractères ainsi que l'extension.

Exemple :

dans la cellule B2 il y aura écrit un nom : ex : 123456

Et je veut que la recherche ce fasse dans "d:photo/" ainsi que dans les sous dossiers

Le fichier trouvé pourra être par ex : 123456 HT 45.jpg

Et si il est trouvé ,ça l'ouvre avec la visionneuse photo de Windows

Si il n'est pas trouvé , une msgbox s'affiche

Je suis sous xl2013pro au boulot

Merci pour l'aide que vous pourrai m'apporter.

bonjour,

les 3 variables, vous pouvez les utiliser comme-çà

MyPath = Range("A1").value     'ce dossier + sous-dossiers
MyPrefix = range("B1").value     '1er caractères
MyExtension = range("C1").value     'extension

Sub Ledoc()

     Dim MyPath, MyPrefix, MyExtension

     MyPath = "d:\photo\"     'ce dossier + sous-dossiers
     MyPrefix = "123456"     '1er caractères
     MyExtension = ".jpg"     'extension

     s = "Dir " & MyPath & MyPrefix & "*" & MyExtension & " /b /s"     '---> ligne de commande pour "SHELL"
     myfiles = Split(CreateObject("wscript.shell").Exec("cmd /c " & s).StdOut.ReadAll, vbCrLf)      'array avec tous les files

     If UBound(myfiles) = -1 Then
          MsgBox "Désolé  !!!", vbCritical, s
     Else
          MsgBox Join(myfiles, vbLf), vbInformation, s     'messagebox avec tous les files
          For i = 0 To UBound(myfiles)
               If Len(myfiles(i)) > 0 Then
                    MsgBox "file numéro : " & i + 1 & "    " & myfiles(i)     'faites quelque chose avec ce file
               End If
          Next
     End If

End Sub

Bonjour merci pour l'aide

J'ai recopié le code en adaptant les variables mais j'ai une erreur.

voir photo ci jointe.

bonsoir, myPath, c'est quoi ?

Bonjour.

C'est un disque réseau accessible directement via le navigateur .

Je ne peut pas donner le chemin pour des raison de confidentialité

bonjour,

Okay, y-a-t-il des espaces dans ce path ? Je pense d'y voir quelques.

Oui aussi bien dans le nom de dossier que dans le nom final des photos .

autre methode

Option Compare Text     'IMPORTANT !!!!!!!!!!!

Sub Ledoc()

     Dim MyPath, MyPrefix, MyExtension
     Dim oFSO As Object, oFolder As Object, oFile As Object, sf
     Dim i As Integer, colFolders As New Collection

     Set dict = CreateObject("scripting.dictionary")

     MyPath = "d:\photo\"     'ce dossier + sous-dossiers
     MyPrefix = "123456"     '1er caractères
     MyExtension = ".jpg"     'extension

     Set oFSO = CreateObject("Scripting.FileSystemObject")
     Set oFolder = oFSO.getfolder(MyPath)

     colFolders.Add oFolder          'start with this folder

     Do While colFolders.Count > 0      'process all folders
          Set oFolder = colFolders(1)    'get a folder to process
          colFolders.Remove 1            'remove item at index 1

          For Each oFile In oFolder.Files
               DoEvents
               sp = Split(oFile, "\")
               sfilename = sp(UBound(sp))
               If sfilename Like MyPrefix & "*" & MyExtension Then dict(oFile) = 1
          Next oFile

     'add any subfolders to the collection for processing
          For Each sf In oFolder.subfolders
               colFolders.Add sf     'add to collection for processing
          Next sf
     Loop

     If dict.Count > 0 Then
          arr = dict.keys
          MsgBox Join(arr, vbLf), , "tous les files"
          Range("A1").Resize(UBound(arr) + 1).Value = Application.Transpose(arr)

          For i = 0 To UBound(arr)
               MsgBox arr(i), vbInformation, i + 1 & " / " & UBound(arr) + 1
          Next
     End If
End Sub

J'ai testé ce code et ça me donne une erreur objet requis et coloris en jaune la ligne : colfolder.remove 1

sorry, je renonce.

Bonjour le fil,

@BsAlv, pourquoi du code aussi tordu quand à l'origine on vous dit "je suis débutant sur VBA"
merci de vous mettre à la porter des demandeurs et d'éviter de sortir votre "science" ainsi

@ledoc, voici un code qui fonctionne

' Déclaration pour Excel 32 ou 64 bits
#If VBA7 Then
  Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
    ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#Else
  Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
    ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

Sub TrouverFichier()
  Dim sPathIni As String, sCrit As String, sFic As String
  ' récupéré chemin du dossier initial
  sPathIni = Range("C2")
  ' Vérifier si dernier antislash sinon l'ajouter
  If Right(sPathIni, 1) <> "\" Then sPathIni = sPathIni & "\"
  ' récupére le critère de recherche
  sCrit = Range("B2")
  ' Vérifier si un fichier existe avec ce critère
  sFic = Dir(sPathIni & "*" & sCrit & "*")
  ' Si retour vide
  If sFic = "" Then
    MsgBox "Aucun fichier qui contiendrait : *" & sCrit & "*" & vbCr _
    & "n'a été trouvé dans " & sPathIni, vbCritical, "OUPS..."
  Else ' sinon
    ShellExecute 0, vbNullString, sPathIni & sFic, vbNullString, vbNullString, 0
  End If
End Sub
End Sub

Et le fichier

A+

bonjour,

@Bruno, voila une suite à votre code simple qui regarde aussi dans les subdirectories.
Je ne sais pas pourquoi il y avait des problèmes, le "d:photo/" a l'air bizar.
Ce n'est pas du "rocket science"

Bonjour à tous,

pourquoi vouloir le faire sur excel alors que des utilitaires 10000 fois plus puissants le font ?
Je te conseille Everything sur www.voidtools.com
Gratuit et réponse instantanée, un bijou.
Sans parler de la recherche incluse dans l'explorateur de fichier
eric

Salut eriiic

Sauf erreur "Everything" ne fait que trouver le fichier s'il existe

LeDoc veut qu'il s'ouvre si trouvé

Au plaisir

Ah, c'est vrai, il faut un double-clic sur celui qui correspond.
Mais si une macro en trouve 2 ou plus il faudra aussi une action utilisateur
C'était aussi un rappel sur la recherche par l'explorateur de fichier. Parfois on passe à coté d'une évidence...

cela n'est pas bête, d:\photo\*123456*.jpg sur la ligne de commande d'Everything

Puis CTRL+S pour l'exporter vers un fichier CSV et puis l'ouvrir dans excel.

Apres installation, cela te prends 30 secondes

Re,

@BsAlv, 30s... autant dire une éternité

Si le but est juste de l'ouvrir, nul besoin de passer par excel, on tombe à 1 s pour les plus lents

re,

encore a améliorer, lancer everything with VBA, mais je connais pas assez d'Everything pour le moment

Sub Teste()
     Dim sPath, sPrefix, sExtension, sComplet

     sPath = "c:\users\eigenaar\downloads\oude files"
     sPrefix = "Af"
     sExtension = ".png"

     sComplet = sPath & IIf(Right(sPath, 1) <> "\", "\*", "") & sPrefix & "*" & sExtension
     sComplet = Replace(sComplet, " ", """ """)'problème avec les espaces !!!

     ChDir "C:\Program Files (x86)\Everything"
     s = "Everything.exe -filename " & sComplet
     CreateObject("wscript.shell").Exec ("cmd /c " & s)
End Sub

par sécurité tu pourrais ajouter -nocase dans la ligne de commande.
Perso je ne complique pas, je reste toujours dans la fenêtre de l'appli

eric