Trouver des images dans des dossiers et pouvoir les copier rapidement

Le 16/01/2024 à 12:38

Bonjour à tous,

J'ai un besoin un peu particulier et j'aurais besoin de votre aide.

J'ai un fichier Excel avec une liste de nom de fichiers. Ces fichiers images sont rangés dans différents répertoires.

15fichier-cmt.xlsx (10.15 Ko)

Mon besoin est : De pouvoir rechercher les images de cette liste dans un répertoire maitre (contenant des sous répertoires) défini et de pouvoir copier les images dans un nouveau répertoire global défini. L'idée est d'éviter de chercher chaque image dans les sous répertoires, car je dois les fournir à un tiers.

Pouvez vous m'aider ?

Merci à vous,

Corentin J

Le 16/01/2024 à 15:36

Bonjour et

A tester :

  • Regarde bien si la référence "Microsoft Scripting RunTime" est activé
  • indique l'adresse du dossier maitre (variable Dossier)
  • indique repertoire copie d'image (variable DossierGlobal)
  • Rien en colonne B et C
  • suppression des # dans tes noms d'images

Et lance la procedure Lister_fichiers

Option Explicit

Sub Lister_fichiers()
'Nécessite d'activer la référence "Microsoft Scripting RunTime"
    Dim Dossier As String

    Dossier = "Z:\Image"    'Dossier maitre avec sous dossier contenant les images
    ListeFichiers Dossier

End Sub

Sub ListeFichiers(Repertoire As String)
    'Nécessite d'activer la référence "Microsoft Scripting RunTime"
    Dim FSO As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim i, DplImage, BaseImage As Long
    Dim DossierGlobal, DossierACopier, FichierACopier As String

DossierGlobal = "C:\DossierGlobal"  'Repertoire de copie d'image

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(Repertoire)

    i = Cells(Rows.Count, 2).End(xlUp).Row + 1

    For Each FileItem In SourceFolder.Files
        Feuil1.Cells(i, 2) = FileItem.ParentFolder
        Feuil1.Cells(i, 3) = FileItem.Name
        i = i + 1
    Next FileItem

    For Each SubFolder In SourceFolder.SubFolders
        ListeFichiers SubFolder.Path
    Next SubFolder

    For DplImage = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        For BaseImage = 1 To Cells(Rows.Count, 2).End(xlUp).Row
            If Feuil1.Cells(DplImage, 1).Value = Feuil1.Cells(BaseImage, 3).Value Then
                DossierACopier = Feuil1.Cells(BaseImage, 2).Value
                FichierACopier = Feuil1.Cells(BaseImage, 3).Value
                FSO.CopyFile DossierACopier & "\" & FichierACopier, DossierGlobal & "\" & FichierACopier
            End If
        Next BaseImage

    Next DplImage

End Sub

A+

Le 16/01/2024 à 16:24

Bonjour,

Merci pour ta réponse, j'ai du déclarer les variables "DossierACopier" et FichierACopier.

La macro fonctionne bien, j'ai juste ajouter un bouton pour l'executer.

Les fichiers sont bien copié, par contre, pour mon exemple, il tourne en boucle, j'ai me suis mis en mode debug, et il traite tous les images (colonne A), copie les images, et ensuite, il recommence.

J'ai pas eu d'autres choix que de le couper violamment pour qu'il me rende la main.

Je n'arrive pas à mettre le doigt sur la boucle infini.

Est-ce que tu peux regarder ? ou au pire, gérer une colonne où, dès que la recherche aboutie (avec copie ou sans parce que pas trouvé l'image) un marqueur est mis dans une cellule, ce qui fait, qu'elle pourrait être controlée pour arrêter la boucle infinie.

Merci beaucoup pour l'aide !

Corentin J

Option Explicit

Sub Lister_fichiers()
'Nécessite d'activer la référence "Microsoft Scripting RunTime"
    Dim Dossier As String

    Dossier = "\\servdata\Dossiers_commun\Commun_marketing\BIBLIOTHEQUES\IMAGES\Produits"    'Dossier maitre avec sous dossier contenant les images
    ListeFichiers Dossier

End Sub

Sub ListeFichiers(Repertoire As String)
    'Nécessite d'activer la référence "Microsoft Scripting RunTime"
    Dim FSO As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim i, DplImage, BaseImage As Long
    Dim DossierGlobal As String
    Dim DossierACopier As String
    Dim FichierACopier As String

DossierGlobal = "\\servdata\Dossiers_commun\Commun_marketing\BIBLIOTHEQUES\IMAGES\Produits\20240116_TEST_CORENTIN"  'Repertoire de copie d'image

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(Repertoire)

    i = Cells(Rows.Count, 2).End(xlUp).Row

    For Each FileItem In SourceFolder.Files
        Feuil1.Cells(i, 2) = FileItem.ParentFolder
        Feuil1.Cells(i, 3) = FileItem.Name
        i = i + 1
    Next FileItem

    For Each SubFolder In SourceFolder.SubFolders
        ListeFichiers SubFolder.Path
    Next SubFolder

    For DplImage = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        For BaseImage = 1 To Cells(Rows.Count, 2).End(xlUp).Row
            If Feuil1.Cells(DplImage, 1).Value = Feuil1.Cells(BaseImage, 3).Value Then
                DossierACopier = Feuil1.Cells(BaseImage, 2).Value
                FichierACopier = Feuil1.Cells(BaseImage, 3).Value
                FSO.CopyFile DossierACopier & "\" & FichierACopier, DossierGlobal & "\" & FichierACopier
            End If
        Next BaseImage

    Next DplImage

End Sub
Le 16/01/2024 à 17:20

J'ai trouvé ! J'ai séparé les deux procédures et le fonctionnement est ok :)

Alors pour abuser de ta gentillesse (merci encore) est-ce qu'il serait possible d'avoir :

  • Une barre d'avancement selon le nombre d'images recherchées (colonne A). Cela permettra à l'utilisateur de se projeter sur la fin du traitement ^^
  • Une identification pour indiquer le fait de ne pas avoir trouvé une image. Mettre la cellule correspondante de la colonne A en rouge par exemple pour l'identifier rapidement ?

Merci encore :)

Ci dessous le code révisé et le fichier

10modele-recherche.zip (301.02 Ko)
Option Explicit

Dim FSO As Scripting.FileSystemObject

Sub Lister_fichiers()
'Nécessite d'activer la référence "Microsoft Scripting RunTime"
    Dim Dossier As String
    Dim rep As Integer

    Dossier = "\\servdata\Dossiers_commun\Commun_marketing\BIBLIOTHEQUES\IMAGES\Produits"    'Dossier maitre avec sous dossier contenant les images

    rep = MsgBox("Etes-vous sur de vouloir lancer la macro ?", vbOKCancel)

    If rep = 1 Then
        ListeFichiers Dossier
        CopieFichiers
        rep = MsgBox("Fin du traitement", vbOKOnly)
    Else
        rep = MsgBox("Traitement non réalisé", vbOKOnly)
    End If

End Sub

Sub ListeFichiers(Repertoire As String)
    'Nécessite d'activer la référence "Microsoft Scripting RunTime"
    Dim SourceFolder As Scripting.Folder
    Dim SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim i As Long

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(Repertoire)

    i = Cells(Rows.Count, 2).End(xlUp).Row

    For Each FileItem In SourceFolder.Files
        Feuil1.Cells(i, 2) = FileItem.ParentFolder
        Feuil1.Cells(i, 3) = FileItem.Name
        i = i + 1
    Next FileItem

    For Each SubFolder In SourceFolder.SubFolders
        ListeFichiers SubFolder.Path
    Next SubFolder

End Sub

Sub CopieFichiers()
    Dim DossierGlobal As String
    Dim i, DplImage, BaseImage As Long
    Dim DossierACopier As String
    Dim FichierACopier As String

    DossierGlobal = "\\servdata\Dossiers_commun\Commun_marketing\BIBLIOTHEQUES\IMAGES\Produits\RECHERCHE"  'Repertoire de copie d'image

    For DplImage = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        For BaseImage = 1 To Cells(Rows.Count, 2).End(xlUp).Row
            If Feuil1.Cells(DplImage, 1).Value = Feuil1.Cells(BaseImage, 3).Value Then
                DossierACopier = Feuil1.Cells(BaseImage, 2).Value
                FichierACopier = Feuil1.Cells(BaseImage, 3).Value
                FSO.CopyFile DossierACopier & "\" & FichierACopier, DossierGlobal & "\" & FichierACopier
            End If
        Next BaseImage

    Next DplImage
End Sub
Le 16/01/2024 à 17:34

Pour la partie barre de progression, en passant par un userform, c'est possible mais plutot long a faire, il faudra une colonne entre la A et B peut etre pour marquer le nombre d'image et le reste a copier mais si l'image n'existe pas la barre n'ira jamais a 100%

pour la partie voir si l'image a été copié j'aurais fait un truc comme ça

Sub CopieFichiers()
    Dim DossierGlobal As String
    Dim i, DplImage, BaseImage As Long
    Dim DossierACopier As String
    Dim FichierACopier As String

    DossierGlobal = "\\servdata\Dossiers_commun\Commun_marketing\BIBLIOTHEQUES\IMAGES\Produits\RECHERCHE"  'Repertoire de copie d'image

    For DplImage = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        Feuil1.Cells(BaseImage, 3).Font.ColorIndex = 3 'rouge
        For BaseImage = 1 To Cells(Rows.Count, 2).End(xlUp).Row
            If Feuil1.Cells(DplImage, 1).Value = Feuil1.Cells(BaseImage, 3).Value Then
                DossierACopier = Feuil1.Cells(BaseImage, 2).Value
                FichierACopier = Feuil1.Cells(BaseImage, 3).Value
                FSO.CopyFile DossierACopier & "\" & FichierACopier, DossierGlobal & "\" & FichierACopier
                Feuil1.Cells(BaseImage, 3).Font.ColorIndex = 4 'vert
            End If
        Next BaseImage
    Next DplImage
End Sub
Feuil1.Cells(BaseImage, 3).Font.ColorIndex = 3 'rouge

Mettre en rouge le nom de l'image au debut et si l'image a été copié passer le nom en vert

 Feuil1.Cells(BaseImage, 3).Font.ColorIndex = 4 'vert

A+

Le 16/01/2024 à 18:12

Bonjour à tous,

pour la progression, un message dans la barre d'état style "Image traitée : 5/30" est facile et rapide à mettre en oeuvre.
Exemple à adapter :

Dim statusBarInitial As Long
statusBarInitial = Application.DisplayStatusBar
Application.DisplayStatusBar = True
    If lig Mod 100 = 0 Then
        Application.StatusBar = "Ligne " & lig & " / " & derlig - 1
        DoEvents
    End If
'.....

Application.DisplayStatusBar = statusBarInitial

eric

Le 17/01/2024 à 12:33

Merci à tous, je vais pouvoir me débrouiller avec tout ca !

Merci encore

Rechercher des sujets similaires à "trouver images dossiers pouvoir copier rapidement"