Copier des fichiers à partir d'une liste

bonjour à tous et à toute

Étant débutant en VBA je souhaiterais savoir si il est possible de créer une macro et si possible de m'aiguiller

je voudrais copier des fichiers qui se trouvent dans des dossiers différents et les regrouper dans un dossier unique tout cela à partir d'un tableau excel qui contient une colonne avec les liens de chaque fichier à copier

comme dans l'image ci dessous je voudrais que les fichiers dont les liens sont en colonne D se retrouve copiés dans un nouveau dossier par exemple d:\\projet\bureau01\

je vous remercie par avance de votre aide

à bientot

Bonjour,

Pourrais-tu joindre ton fichier ... ce sera beaucoup plus utile qu'une simple image ...

James007 a écrit :

Bonjour,

Pourrais-tu joindre ton fichier ... ce sera beaucoup plus utile qu'une simple image ...

Bonsoir, j ai du mal formulė ma question, car je ne vois pas ce que va apporter le fait que je poste un fichier , l image illustre un exemple de ce que je souhaite arriver à faire.

mais bon je posterai le ficher. .....demain

A+

Bonjour tenrev...

En supposant l'image d'un tableau de ce genre...

Voici un code (inspiré d'un très vieux code de Mytâ (2011) https://forum.excel-pratique.com/excel/copier-fichiers-xls-vers-repertoire-t26489.html) en plus beaucoup plus élaboré avec Vérification d'existence des fichiers, Confirmation des écrasements, Gestion des erreurs...

/code à copier dans un module standard, à adapter en fonction du cas/

Sub CopierRepUnique()
Dim tabFic()
Dim tmp
Dim confirme As Boolean
Dim confTous As Boolean
Dim repBox
Dim errCode

Dim ficObjSys As Object, oldRep, newRep, ficAct

    Set ficObjSys = CreateObject("Scripting.FileSystemObject")

    confTous = False

    newRep = Cells(3, 3)
    tabFic = Range(Cells(7, 2), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 5))
    For cptfic = 1 To UBound(tabFic, 1)
        tmp = Split(tabFic(cptfic, 4), "\")
        oldRep = ""
        For cptrep = UBound(tmp, 1) - 1 To 0 Step -1
            oldRep = tmp(cptrep) + "\" + oldRep
        Next
        ficAct = tmp(UBound(tmp, 1))

        If FicExisteDeja(newRep & ficAct) And Not confTous Then
            repBox = ConfirmeBox(tabFic(cptfic, 2), ficAct)
            confirme = repBox = vbYes
            confTous = repBox = vbCancel
        Else
            confirme = True
        End If

        If confirme Or confTous Then
            On Error GoTo errCopie
            ficObjSys.copyfile oldRep & ficAct, newRep & ficAct
            On Error GoTo 0
        End If
    Next

    Set ficObjSys = Nothing

    Exit Sub

errCopie:
    If Err.Number = 53 Then
        errCode = "Fichier Absent"
    Else
        errCode = "Erreur " & Err.Number & " sur..."
    End If
    MsgBox ficAct & vbCrLf & "du produit " & tabFic(cptfic, 2), vbCritical, errCode
    Resume Next

End Sub

Function FicExisteDeja(lequel)

    FicExisteDeja = True
    On Error GoTo errExisteDeja
    Open lequel For Input As FreeFile()
    Close #FreeFile()
    On Error GoTo 0

    Exit Function

errExisteDeja:
    FicExisteDeja = False
    On Error GoTo 0

End Function

Function ConfirmeBox(produit, fic)
    ConfirmeBox = MsgBox( _
        "La photo " & fic & vbCrLf & _
        "du produit " & produit & vbCrLf & _
        "existe déjà dans ce répoertoire..." & vbCrLf & vbCrLf & _
        "Voulez-vous le Remplacer ?" & vbCrLf & vbCrLf & _
        "(Annuler pour ne plus poser la Question)", vbQuestion + vbYesNoCancel, "ATTENTION !")
End Function

PS: Je propose le fichier de cet manière parce qu'il s'agit d'un module d'une application plus complexe.../

Merci beaucoup NCC 1701

C'est cool , je vais essayer de comprendre tout ça et je vous tiens au courant et redemanderai certainement de l'aide

Pour info je modelise des composants 3D avec des attributs dynamiques (le lien des photos entre autre) je génère ensuite un fichier Excel relatif à ma scène 3d, ce fichier me permet de fusionner mes articles et de composer un catalogue dans indesing , le seul bémol c est qUe indesign impose ques les photos soient regroupées dans le repertoire du projet d'où ma recherche

A+

Bonjour,

car je ne vois pas ce que va apporter le fait que je poste un fichier

C'était uniquement pour t'aider ... et adapter le code de la boucle précisément aux éléments de ta colonne D ...

James007 a écrit :

Bonjour,

car je ne vois pas ce que va apporter le fait que je poste un fichier

C'était uniquement pour t'aider ... et adapter le code de la boucle précisément aux éléments de ta colonne D ...

Ok merci bien

je vais essayer d avancer et je reviens poster si j arrive à quelque chose , sinon je redemanderai de l aide

A plus

Re,

Pas de problème ...

Bonjour,

j'ai réussi à faire ce que je souhaitais, mais finalement j'ai suivi le lien donné par NCC 1701

https://forum.excel-pratique.com/excel/copier-fichiers-xls-vers-repertoire-t26489.html

et j'ai pris le code de Mytâ , c'est plus simple pour moi débutant en macro vba à comprendre et à adapter

ton code NCC 1701 et certainement plus élaboré , mais comme je ne comprend pas tout , je n'arrive pas à le faire fonctionner

ci dessous le code que j'ai finalement pris :

Sub repCopierFichier()
Dim fso As Object, Dossier_cherché$, Dossier_récepteur$, Fichier_cherché$

Set fso = CreateObject("Scripting.FileSystemObject")
Dossier_récepteur = Range("F12")
Range("B12").Activate
Do Until ActiveCell = ""
Dossier_cherché = ActiveCell
Fichier_cherché = ActiveCell.Offset(0, 1)
fso.CopyFile Dossier_cherché & "\" & Fichier_cherché, Dossier_récepteur & "\" & Fichier_cherché
ActiveCell.Offset(1, 0).Activate
Loop

End Sub

en tout cas merci beaucoup de m'avoir orienté au bon endroit et d'avoir pris le temps de me proposer une solution

je garde ce post sous le coude j'y reviendrai certainement quand je serai un plus plus avancé en macro

je met le sujet résolu

à bientot

Bonjour tenrev

tenrev a écrit :

j'ai réussi à faire ce que je souhaitais, mais finalement j'ai suivi le lien donné par NCC 1701

tenrev a écrit :

en tout cas merci beaucoup de m'avoir orienté au bon endroit et d'avoir pris le temps de me proposer une solution je garde ce post sous le coude j'y reviendrai certainement quand je serai un plus plus avancé en macro je met le sujet résolu

par contre étant nouveau sur le forum , je ne sais pas si c'est possible de mettre le sujet résolu ?

et comment faire ?

merci à plus

(re)

Il faut cliquer sur le "point d'exclamation" à gauche de "citer" en haut des messages...

NCC 1701 a écrit :

(re)

Il faut cliquer sur le "point d'exclamation" à gauche de "citer" en haut des messages...

merci de m'avoir mis sur la piste , c'est pas le point d'exclamation , mais le V qui est à coté

Bonjour tenrev

Presque la forme oui, mais il y a un point d'exclamation dedans !

Regarde avec une loupe... tu verras !