langenoir11
XLDnaute Nouveau
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
confused:
Je suis pas un pro en vb donc...
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
Code:
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...
Dernière édition: