Bonjour,
J'ai utilisé la macro de récupération des fichiers et ça marche à merveille!
Sauf que j'ai un besoin particulier:
J'ai un répertoire dans lequel il y a plusieurs fichiers, chaque fichier est nommé d'une façon standard:
"Nom salle_type de données" (il y a 3 types de données)
mon fichier Excel est composé de 4 colonnes :
A=nom salle; B=Chemin fichier type de données1; C=Chemin fichier type de données2; D=Chemin fichier type de données3
Le but, est de pouvoir ouvrir un répertoire:
Récupérer les noms des salles (sans doublon) dans la colonne A
Récupérer le chemin du fichier type de données 1 dans la colonne B (s'il y en a) (Hypertexte)
Récupérer le chemin du fichier type de données 2 dans la colonne C (s'il y en a)(Hypertexte)
Récupérer le chemin du fichier type de données 3 dans la colonne D(s'il y en a)(Hypertexte)
Ci joint mon fichier avec la macro que j'ai un peu bricolé pour récupérer les valeurs sans doublons dans la colonne A.
Sub LireFichier()
Dim Obj, RepP, Fich, TB, F
Dim Rep As String, i As Integer, x As Integer
Range("a2:a200").ClearContents 'suuprimer les cellule remplies_____________
Range("b2:b200").ClearContents 'suuprimer les cellule remplies____________
Range("c2:c200").ClearContents 'suuprimer les cellule remplies___________
Range("d2:d200").ClearContents 'suuprimer les cellule remplies___________
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
On Error Resume Next 'si annuler
Rep = .SelectedItems(1)
If Err.Number <> 0 Then Exit Sub
End With
Rep = Rep & "\"
Set Obj = CreateObject("Scripting.FileSystemObject")
Set RepP = Obj.Getfolder(Rep)
Set Fich = RepP.Files
With ActiveSheet
i = 2 'première ligne où commencer
On Error Resume Next 'si pas d'extension
For Each F In Fich
TB = Split(F.Name, "_Liste")
.Cells(i, "f") = TB(0)
'Et éventuellement un lien HyperText pour appeler le fichier
.Hyperlinks.Add Anchor:=.Cells(i, "g"), Address:= _
Rep & F.Name, TextToDisplay:=Rep & F.Name
i = i + 1
Next F
'Placer les valeurs sans doublon dans la colonne a
Range("f2:f200").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("a2"), Unique:=True
End With
Set Obj = Nothing
Set RepP = Nothing
Set Fich = Nothing
End Sub