Rechercher un fichier dans un repertoire (RESOLU)

[langenoir11]

Bonjour,
J'ai fait une macro qui recherche un fichier dans un repertoire, si elle trouve un fichier jpg elle copie le chemin dans une cellule, puis si elle trouve le fichier excel elle copie le chemin du fichier dan sune autre cellule

Exemple dans une cellule A1 j'ai TOTO45

Ma macro cherche tous les fichier qui contienne tle mot TOTO45 (ex: C:\monficher TOTO45 tata.jpg) ou (ex: C:\monficher TOTO45 titi.jpg) pour cela pas de probleme.

Mais le probleme c'est que ouvre aussi les fichiers en (ex: C:\monficher TOTO456 tata.jpg) ou (ex: C:\monficher TOTO45568 titi.jpg)
voici ma macro

Sub ChargeFichier()

On Error GoTo erreur26

NomFichier = ActiveWorkbook.Name

Dim FichierPDC As String
Dim Numinterne As String
Dim NumPDC As String
Dim i As Integer

Numinterne = Feuil1.[RI_NUM_INTERNE]

'_______________Recherche du numero interne dans le nom du fichier UNIQUE_________________

'permet de choisir la ligne
i = 20

NumPDC = 1

Folder = Feuil6.[ZONE_CHEMIN_PDC] 'Répertoire de recherche

'''''''''Version 1 permet de recuperer le chemin du fichier JPG'''''''''''''
Set obj = CreateObject("Scripting.FileSystemObject")
For Each File In obj.Getfolder(Folder).Files 'On parcourt les fichiers du répertoire
Extention = Right(File, 3)

'Recherche du JPG correspondant
     
    If InStr(File, Numinterne) <> 0 Then
        'Controle d'extention (QUE jpg)
        
        If Extention <> "jpg" Then GoTo suite
        Sheets("feuil1").Select
        'Stocke la valeur dans la feuil1 Celule BE
        Range("BE" & i) = File
        i = i + 1

End If
suite:
Next

i = 20
Set obj = CreateObject("Scripting.FileSystemObject")
For Each File In obj.Getfolder(Folder).Files 'On parcourt les fichiers du répertoire
Extention = Right(File, 3)

    If InStr(File, Numinterne) <> 0 Then
        'Controle d'extention (QUE xls)
        If Extention <> "xls" Then GoTo fin
        'enregistrement du chemin (file sur la feuil1) permet à l'enregistrement de connaitre le chemin de retour
        
        Sheets("feuil1").Select
        
        Range("BC" & i) = File
        Range("BD" & i) = "PDC " & NumPDC
        i = i + 1
        
        FichierPDC = File.Name
        Workbooks.Open filename:=Folder & FichierPDC
        'Ouvre le PDC recherché
        Workbooks(FichierPDC).Activate
               
fin:
    End If
Next
Range("BC39").Select
If ActiveCell.Value = 0 Then
Range("A1").Select
MsgBox "Pas de PDC trouvé"
Else
Range("A1").Select
'MsgBox "PDC Inséré"


End If

GoTo Apreserreur
erreur26:
CreateObject("Wscript.shell").Popup "Erreur d'execution, risque de perte des données !" & Chr(10) & "Erreur Module 26" & Chr(10) & "CONTACTER VOTRE ADMINISTRATEUR", , "ERREUR CRITIQUE", vbCritical
Apreserreur:

End Sub

confused:
Je suis pas un pro en vb donc...

 

[Papou-net]

Re : Rechercher un fichier dans un repertoire

Bonsoir langenoir,

Ta question n'est pas très explicite ou, du moins, je n'ai pas compris la demande suivante :

Mais le probleme c'est que ouvre aussi les fichiers en (ex: C:\monficher TOTO456 tata.jpg) ou (ex: C:\monficher TOTO45568 titi.jpg)

Cela ne m'a pas empêché de regarder ton code et de te proposer une version modifiée :

Sub ChargeFichier()

On Error GoTo erreur26
NomFichier = ActiveWorkbook.Name
Dim FichierPDC As String
Dim Numinterne As String
Dim NumPDC As String
Dim i As Integer

Numinterne = Feuil1.[RI_NUM_INTERNE]

'_______________Recherche du numero interne dans le nom du fichier UNIQUE_________________

'permet de choisir la ligne
i = 20
NumPDC = 1
Folder = Feuil6.[ZONE_CHEMIN_PDC] 'Répertoire de recherche

'''''''''Version 1 permet de recuperer le chemin du fichier JPG'''''''''''''
Set obj = CreateObject("Scripting.FileSystemObject")
For Each File In obj.Getfolder(Folder).Files 'On parcourt les fichiers du répertoire
Extention = Right(File, 3)
' Modifié par papou-net -------------------------------------------------------------------------------
Sheets("feuil1").Select
'Recherche du JPG correspondant
  If InStr(File, Numinterne) <> 0 Then
    'Controle d'extention (QUE jpg)
    If Extention = "jpg" Then
      'Stocke la valeur dans la feuil1 Celule BE
      Range("BE" & i) = File
      i = i + 1
    End If
    If Extention = "xls" Then
      'Controle d'extention (QUE xls)
      'enregistrement du chemin (file sur la feuil1) permet à l'enregistrement de connaitre le chemin de retour
      Range("BC" & i) = File
      Range("BD" & i) = "PDC " & NumPDC
      i = i + 1
      FichierPDC = File.Name
      Workbooks.Open Filename:=Folder & FichierPDC
      'Ouvre le PDC recherché
      Workbooks(FichierPDC).Activate
    End If
  End If
Next
' Fin des modifications ------------------------------------------------------------------------------
Range("BC39").Select
If ActiveCell.Value = 0 Then
  Range("A1").Select
  MsgBox "Pas de PDC trouvé"
  Else
  Range("A1").Select
  'MsgBox "PDC Inséré"
End If

GoTo Apreserreur
erreur26:
CreateObject("Wscript.shell").Popup "Erreur d'execution, risque de perte des données !" & Chr(10) & "Erreur Module 26" & Chr(10) & "CONTACTER VOTRE ADMINISTRATEUR", , "ERREUR CRITIQUE", vbCritical
Apreserreur:
End Sub

Une seule boucle suffit à détecter les fichiers jpg et xls et, en modifiant le signe de comparaison dans les tests conditionnels If...Then ("=" au lieu de "<>"), cela supprime l'utilité des lignes d'étiquette "suite:" et "fin:". Par contre, j'ai un doute sur la feuille concernée par les cellules BC39 et A1 dans les lignes qui suivent "Fin des modifications --------"

Je ne suis pas certain que tout ceci t'aidera à résoudre la question, mais ton code s'en trouve allégé et mieux structuré. Sinon, n'hésite pas à revenir sur ce sujet en précisant davantage le problème.

Cordialement.

 

[langenoir11]

Re: Rechercher un fichier dans un repertoire

Merci pour la réponse cela m'a permis de résoudre mon problème

Cdt