Option Explicit
Option Compare Text
Dim FS As Object
Dim Existe As Boolean
Const Destination = "F:\Tests_Excels\ID\"
'-----------------------------------------------------
Sub Test_GetFolder()
Dim Chemin As String, expression As String
Dim C As Range
'Répertoire de départ
Chemin = "F:\Tests_Excels\Arbo_test"
Set FS = CreateObject("Scripting.FileSystemObject")
With Worksheets("ID") 'Nom Feuille à définir
For Each C In .Range("A3:A" & _
.Range("A65536").End(xlUp).Row)
If C <> "" Then
Existe = False
expression = C.Value
Call GetFolders(Chemin, expression, C, True)
End If
Next
End With
'Ce qui précède testait le contenu des sous-répertoires
'cette ligne teste le contenu source lui-même.
Call Trouver_Copier_Fichier(Chemin, expression, C)
Set FS = Nothing
End Sub
'-----------------------------------------------------
Function GetFolders(Chemin As String, _
expression As String, Rg As Range, _
Optional Récursif As Boolean)
Dim répertoire As String
Dim MyFolder As Object, MySubFolder As Object
Set MyFolder = FS.GetFolder(Chemin)
'si récursif est égale à true, rappel de la fonction
If Récursif Then
'Boucle pour chaque sous-répertoire
For Each MySubFolder In MyFolder.SubFolders
répertoire = Chemin & "\" & MySubFolder.Name
'Recherche fichier + copie si trouve
Call Trouver_Copier_Fichier(répertoire, expression, Rg)
'Vérifier le sous-répertoire
GetFolders MySubFolder.Path, expression, Rg, True
Next
End If
End Function
'-----------------------------------------------------
Sub Trouver_Copier_Fichier(répertoire As String, _
expression As String, Rg As Range)
Dim Fichier As String
'Recherche fichier contenant "Expression définie"
'ayant une extension de fichier ".pdf"
Fichier = Dir(répertoire & "\" & "*" & _
expression & "*" & ".pdf")
Do While Fichier <> ""
'Existe = true si le répertoire-destination
' a été créée
If Existe = False Then
'création du répertoire
Call Créer_Répertoire(expression)
'Créer le lien hypertexte
Rg.Offset(, 1).Hyperlinks.Add Rg.Offset(, 1), _
Destination & expression, , , _
Destination & expression
Existe = True
End If
'Copie du fichier vers le nouveau répertoire
FS.CopyFile répertoire & "\" & Fichier, _
Destination & expression & "\" & Fichier
Fichier = Dir()
Loop
End Sub
'-----------------------------------------------------
Sub Créer_Répertoire(expression As String)
Dim Commande As String, Lecteur As String
Dim T As Double
'S'assurer d'être sur le bon lecteur où les
'répertoires doivent être créé
Lecteur = Left(Destination, 1)
ChDrive Lecteur
Commande = Environ("comspec") & " /c mkdir " & _
Destination & expression
Shell Commande, 0
T = Timer + .4
Do While Timer <= T
DoEvents
Loop
End Sub
'-----------------------------------------------------