VBA pour copier une liste de pdf dans un répertoire vers un autre

Bonjour,

Pour faire simple, je souhaiterais copier un grand nombre de fichiers pdf (des plans de pièces) qui sont aujourd'hui dans plein de sous-dossiers d'un répertoire vers un dossier qui les centraliserait pour y avoir accès rapidement et facilement.

J'ai déjà ressorti la liste des fichiers pdf (nom de la pièce + indice) dans un fichier Excel.

Ma question est la suivante, est ce qu'une macro ou VBA pourrait aller chercher dans le répertoire de base et dans ses sous-dossiers les plans et les coller dans un nouveau répertoire unique ?

Sachant qu'il est possible que certains plans n'existent pas dans le répertoire de base.

J'espère avoir été assez clair dans mes explications

Merci de votre aide

Bonjour,

Oui vous pouvez copier/coller des fichiers via VBA.

Le principe :

Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")

fso.CopyFile source, destination[, overwrite] 

via la Méthode CopyFile (Visual Basic pour Applications) | Microsoft Learn

Par contre je n'ai pas bien compris comment vous avez récupéré vos données : ce n'est pas simplement le nom des fichiers dont vous avez besoin mais bien tout le chemin jusqu'au fichier

Par exemple :

source = "C:\Users\PatPatrouille\Documents\test.jpg"
destination = "C:\MES_FICHIERS\test.jpg"

A voir selon votre aisance avec le VBA. Si c'est peu clair veuillez joindre un fichier d'exemple, ou meme préciser car on peut vous faire un code pour aller chercher tous les fichiers dans les sous-dossiers d'un dossier donné par exemple.

Merci pour ce premier retour, je suis novice en VBA donc c'est compliqué pour moi.

En gros je sais que le fichier pdf en bout de chemin d'accès (si il existe) s'appelle par exemple : 4108021-D(.pdf) car c'est le nom de la pièce chez nous. En revanche ce que je ne sais pas c'est si le fichier pdf existe réellement et si oui ou est ce qu'il est ranger dans de nombreux sous-répertoires de Y:\BE

J'ai fait appelle également a une IA qui me donne ce code :

Sub CopyPDFs()
Dim srcFolder As String
Dim destFolder1 As String
Dim destFolder2 As String
Dim cell As Range
Dim fileName As String

srcFolder = "Y:\3-BE\"
destFolder1 = "Y:\4-PRODUCTION\Plan\"

For Each cell In ThisWorkbook.Sheets(1).Range("A2:A36338")
fileName = cell.Value

If Len(Dir(srcFolder & fileName)) <> 0 Then
FileCopy srcFolder & fileName, destFolder1 & fileName
End If
Next cell

MsgBox "File copy operation completed."
End Sub

Je ne sais pas ce que cela vaut.

Ci-joint, voici une petite liste de pièces

C'est pas trop mal mais il ne vérifie pas les sous-dossiers du dossier source. Je vous enverrai un code demain. Il faudrait que j'arrive à retrouver il y a quelques jours quelqu'un a posté un code parfait pour la recherche itérative dans tous les sous-dossiers... Mais bon j'ai répondu à tellement de trucs que j'ai perdu le fil.

Super, merci de votre aide

Bonjour,

Veuillez trouver ci-joint une macro, testée de mon coté sans problèmes. J'espère qu'il n'y aura pas de problèmes d'accès aux fichiers serveurs de votre coté.

Le code, repris notamment sur le post

https://forum.excel-pratique.com/excel/affichage-plusieurs-adresses-de-fichiers-recherches-195176

Sub main()
  Application.ScreenUpdating = False

  Dim dossierParent As String
  dossierParent = ThisWorkbook.Worksheets(1).Range("srcFolder").Value2

  Dim dossierDestination As String
  dossierDestination = ThisWorkbook.Worksheets(1).Range("destFolder").Value2

  Dim addLinks As Boolean
  addLinks = ThisWorkbook.Worksheets(1).Range("addLinks").Value2

  Dim listeFichiers
  With ThisWorkbook.Worksheets(1).Range("A1")
    listeFichiers = Application.Transpose(Range(.Cells, .End(xlDown)).Value2)
  End With

  Dim i As Long, baseAdresse As String
  For i = LBound(listeFichiers) To UBound(listeFichiers)
    baseAdresse = RechercherFichier(dossierParent, CStr(listeFichiers(i)))
    If baseAdresse <> vbNullString Then
      FileCopy baseAdresse, dossierDestination & "\" & CStr(listeFichiers(i))
      ' Debug.Print baseAdresse & " copied to " & dossierDestination & "\" & CStr(listeFichiers(i))

      ' optionnel : lien vers le fichier originel
      If addLinks Then
        With ThisWorkbook.Worksheets(1).Range("B1").Offset(i - 1, 0)
          .Hyperlinks.Add Anchor:=.Cells(1, 1), Address:=baseAdresse, TextToDisplay:=baseAdresse
        End With
      End If
    End If
  Next i

End Sub

Function RechercherFichier(dossier As String, nomFichierPartiel As String) As String
  ' via https://forum.excel-pratique.com/excel/affichage-plusieurs-adresses-de-fichiers-recherches-195176
  Dim fso As Object
  Dim dossierCourant As Object
  Dim fichier As Object
  Dim sousDossier As Object
  Dim cheminFichier As String

  Set fso = CreateObject("Scripting.FileSystemObject")
  Set dossierCourant = fso.GetFolder(dossier)

  ' Parcourir chaque fichier dans le dossier courant
  For Each fichier In dossierCourant.Files
    If (fichier.Name = nomFichierPartiel) Then
      RechercherFichier = fichier.Path
      Exit Function
    End If
  Next fichier

  ' Parcourir chaque sous-dossier dans le dossier courant
  For Each sousDossier In dossierCourant.SubFolders
    cheminFichier = RechercherFichier(sousDossier.Path, nomFichierPartiel)
    If cheminFichier <> vbNullString Then
      RechercherFichier = cheminFichier
      Exit Function
    End If
  Next sousDossier

  ' Si aucun fichier n'est trouv�
  RechercherFichier = vbNullString
End Function

Merci, cela a l'air de fonctionner mais j'ai l'impression que la macro ne s'arrête jamais de chercher même lorsque le fichier est bien copier dans le dossier de destination, ce qui fait un peu tout planter. Sachant que j'ai environs 10 000 plans à copier.

Je n'ai également pas compris l'utilité de la case a cocher "Ajout liens :", pouvez vous m'éclairer.

Merci

Bonjour,

Oui j'avais un peu peur de ça…

Il faut savoir que de base le VBA n'est pas une flèche.

Là vous lui demandez de chercher dans TOUS LES FICHIERS contenus dans un dossier et ses sous-dossiers : un fichier, puis un autre, puis un autre…

alors certe la boucle s'arrete quand elle a trouvé mais elle recommence à 0 pour le fichier suivant…

Je suis en train de réfléchir à une alternative :

Si au lieu de cela la macro enregistre 1x la liste de tous les fichiers dispo, puis ensuite recherche dans cette liste. Ce devrait etre plus rapide. Mais n'oubliez pas qu'il y aura toujours un temps d'exécution lent.

Pour les liens c'est simplement une idée qui m'est venue, puisque vous cherchez des fichiers, quand il est trouvé (en plus de le copier), le lien vers l'emplacement original est indiqué dans le classeur. si vous décochez la case non.

Pour finir, le principal problème en dehors de l'algorithme c'est la précision que vous lui donnez. Plus le dossier de recherche est précis et plus l'algorithme sera rapide.

Oui d'accord je comprend, je me doutais que ça venait de cela

Avez vous une "structure type" des noms de fichiers. Dans votre exemple ils étaient tous du gerne "00000000-A.pdf" 8 chiffres, trait d'union, une lettre, .pdf ?

Si c'est toujours le cas ca me permet d'accélérer considérablement la macro.

Je vais procéder de manière inverse :

Lire tous les fichiers du répertoire et les tester avec la liste que vous donnez. Ca devrait etre beaucoup plus rapide. Si vous pouvez répondre à la question ci-dessus c'est important. Au moins savoir si les extensions sont toujours en pdf. MErci

Oui le fichier est structuré de 7 chiffres commencant par 41, 42, 43, 44 ou 45

ex : 4115648-A.pdf, 4565874-B.pdf

Mais il arrive qu'il n'y est pas d'indice (C'est un indice qu'on met lorsque l'on fait une modif sur le plan original)

Donc parfois le pdf se nomme uniquement de 7 chiffres, ex : 4356897.pdf

D'accord super donc toujours 7 chiffres, compris entre 4 100 000 et 4 599 999, potentiellement un indice, et du pdf. Je pars sur ces critères pour effectuer un premier tri, et ensuite chercher dans la liste "potentielle" les fichiers listés.

Je reviens vers vous quand j'ai une proposition.

Oui c'est ça, ok super merci

Re,

Ci-après une macro plus rapide (mais encore lente car il y a beaucoup de tests à faire), mais bon je ne l'ai testé que dans mon dossier téléchargements, je n'y ai pas non plus des milliers de fichiers.

J'ai désactivé les hyperliens pour aller plus vite.

Attention TOUS LES FICHIERS doivent respecter les règles pré-établies, à savoir nom du type

"41XXXXX.pdf" ou "41XXXXX-W.pdf" avec X un emplacement de numéro et W de lettre.

Je vous conseille de faire un test avant de le lancer vraiment pour vous assurer que ca marche, car l'éxécution pour 10 000 fichiers sera de toute façon longue.

Ci-après le code, en utilisant un dictionnaire.

Sub main()
  Application.ScreenUpdating = False

  Dim dossierParent As String
  dossierParent = ThisWorkbook.Worksheets(1).Range("srcFolder").Value2

  Dim dossierDestination As String
  dossierDestination = ThisWorkbook.Worksheets(1).Range("destFolder").Value2

  Dim addLinks As Boolean
  addLinks = ThisWorkbook.Worksheets(1).Range("addLinks").Value2

  ' liste des fichiers � trouver
  Dim fichiersAChercher
  With ThisWorkbook.Worksheets(1).Range("A1")
    fichiersAChercher = Application.Transpose(Range(.Cells, .End(xlDown)).Value2)
  End With

  ' dictionnaire des fichiers potentiels
  Dim fichiersTrouves As Object
  Set fichiersTrouves = getFilesLike(dossierParent)

  Dim i As Long, nomFichier As String
  For i = LBound(fichiersAChercher) To UBound(fichiersAChercher)
    nomFichier = CStr(fichiersAChercher(i))

    If fichiersTrouves.Exists(nomFichier) Then
      FileCopy fichiersTrouves(nomFichier), dossierDestination & "\" & nomFichier
      ' Debug.Print fichiersTrouves(nomFichier) & " copied to " & dossierDestination & "\" & nomFichier
      ' suppression de la liste pour acc�l�rer les recherches suivantes
      fichiersTrouves.Remove nomFichier
    End If
'      ' optionnel : lien vers le fichier originel
'      If addLinks Then
'        With ThisWorkbook.Worksheets(1).Range("B1").Offset(i - 1, 0)
'          .Hyperlinks.Add Anchor:=.Cells(1, 1), Address:=baseAdresse, TextToDisplay:=baseAdresse
'        End With
'      End If
'    End If
  Next i

End Sub

Function getFilesLike(dir As String) As Object
  ' updated
  Dim dictFiles As Object
  Set dictFiles = CreateObject("Scripting.Dictionary")
  dictFiles.CompareMode = vbTextCompare

  Dim fso As Object
  Set fso = CreateObject("Scripting.FileSystemObject")

  Dim currentFolder As Object
  Set currentFolder = fso.GetFolder(dir)

  ' Parcourir chaque fichier dans le dossier courant
  Dim currentFile As Object, currentName As String
  For Each currentFile In currentFolder.Files
    currentName = currentFile.Name
    ' 1 verif du nom suivant le pattern d�crit
    If MatchPattern(currentName) Then
      ' 2 verif si d�ja dans la liste
      If Not dictFiles.Exists(currentName) Then
        dictFiles.Add currentName, currentFile.Path
      End If
    End If
  Next currentFile

  ' Parcourir r�cursif de chaque sous-dossier dans le dossier courant
  Dim subFolder As Object
  For Each subFolder In currentFolder.SubFolders
    Dim fileToAdd As Variant, subFolderFiles As Object
    Set subFolderFiles = getFilesLike(subFolder.Path)

    If subFolderFiles.Count > 0 Then
      For Each fileToAdd In subFolderFiles.Keys
        If Not dictFiles.Exists(currentName) Then
          ' ajout dans le dictionnaire courant
          dictFiles.Add fileToAdd, subFolderFiles(fileToAdd)
        End If
      Next fileToAdd
    End If

  Next subFolder

  Set getFilesLike = dictFiles
End Function

Function MatchPattern(fileName As String) As Boolean
  MatchPattern = (fileName Like "4[1-5]#####[-][A-Z].pdf" Or fileName Like "4[1-5]#####.pdf")
End Function

Alors là du coup ça ne fonctionne plus, les plans ne vont plus ce copier dans le répertoire de destination.

J'ai essayé en mettant des fichiers sources beaucoup plus précis et ça ne fonctionne pas.

Mais bon je pense qu'il y a trop de sous dossiers dans le repertoire sources, pour certains plans il faut aller chercher le plan dans une arborescence de 5 sous dossiers pour arriver au plan. Je pense que c'est trop energivore pour le processeur et la Ram

Ca alors… Etes vous bien sur d'avoir entré les noms de dossiers et de fichiers correctement ? Les fichiers sont ils en .pdf ou .PDF ?

car… Je viens de réessayer chez moi, certes sur un petit échantillon, mais ça fonctionne !

Bonjour,

Une proposition :

Bonjour,

Merci beaucoup pour votre aide, cela fonctionne.

Bonjour,

Par curiosité, le fichier de Optimix est-il plus rapide ? Je l'ai regardé et je remarque que la boucle est identique à celle que je vous avais envoyée au début, "trop lente". D'où mon interrogation.

De plus il copie tous les pdf sans distinction des titres.