Copier / Coller images en masse

Bonjour a tous,

J'ai une liste de photo avec des noms correspondant au plage des références a uploader dans notre ERP, exemple "image 1" (sur un dossier de mon ordinateur) avec le nom "Ref 1 a 5" et j'aimerai dupliquer la photo avec chacune un nom, dans mon exemple j'aurai 5 photos intitulé 1 / 2 / 3 / 4 / 5.

J'ai réussi a faire une liste de correspondance image / Ref, j'arrive a importer les photos dans excel par contre je n'arrive pas a enregistrer l'image sur mon PC (exporter) depuis excel.

Ci-dessous le code que j'ai, la macro s'arrête sur la ligne "Selection.Export ".....", Pouvez vous m'aider a redessiner la Macro proprement ?

Sub ddsq()
For i = 2 To 63
refdeb = Cells(i, 3)
reffin = Cells(i, 4)
For y = refdeb To reffin
ref = Cells(i, 2)
ActiveSheet.Pictures.Insert( _
"C:\Users\MOI\Downloads\Nouveau dossier\" & ref).Select
Selection.Export "C:\Users\MOI\Downloads\Nouveau dossier\rename\" & y & ".jpg"
Selection.Delete
Next y
Next i

End Sub

Merci

Edit modo : Bonjour et

SVP code à mettre entre balises avec le bouton </> . Merci d'y faire attention la prochaine fois
Mettez votre version excel. "Pro" ne veut rien dire et n'aide pas celui qui vous répond (2013, 2016, 2019, MAC2011,....)

Bonjour,

A tester :

Sub Ddsq()

Dim NumeroFichier As Integer
Dim oFSO As Object, FolderEnCours As Object, FichierEnCours As Object
Dim RepertoireSource As String, RepertoireCible As String, ExtensionFichier As String

    RepertoireSource = "C:\Users\MOI\Downloads\Nouveau dossier\"
    RepertoireCible = "C:\Users\MOI\Downloads\Nouveau dossier\rename\"

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    With oFSO
        If .FolderExists(RepertoireSource) And .FolderExists(RepertoireCible) Then
           Set FolderEnCours = .GetFolder(RepertoireSource)
           If FolderEnCours.Files.Count > 0 Then
              NumeroFichier = 1
              For Each FichierEnCours In FolderEnCours.Files
                  ExtensionFichier = .GetExtensionName(FichierEnCours)
                  .CopyFile FichierEnCours, RepertoireCible & NumeroFichier & "." & ExtensionFichier
                  NumeroFichier = NumeroFichier + 1
              Next FichierEnCours
           End If
        End If
    End With

    Set oFSO = Nothing:  Set FolderEnCours = Nothing

End Sub

Slt,

ok Modo :) Nous avons la dernière version du pack office au boulot --> Office 365 je crois

Merci Eric pour ta réponse mais j'ai du mal a intégrer ton code pour le rendre a 100% compatible avec ce que je veux faire

Ci-dessous une tentative d'intégration mais je ne sais pas comment "exprimer" la ligne "xxxxxxx"

Sub Ddsq()

Dim NumeroFichier As Integer
Dim oFSO As Object, FolderEnCours As Object, FichierEnCours As Object
Dim RepertoireSource As String, RepertoireCible As String, ExtensionFichier As String
RepertoireSource = "C:\Users\MOI\Downloads\Nouveau dossier\"
RepertoireCible = "C:\Users\MOI\Downloads\Nouveau dossier\rename\"

    For i = 2 To 63 'correspond au nombre de fichier que j'ai dans mon dossier de data brut
        refdeb = Cells(i, 3) 'Correspond a la 1er ref que représente mon fichier --> 1 dans mon exemple
        reffin = Cells(i, 4) 'Correspond a la derniere ref que représente mon fichier --> 5 dans mon exemple
        For y = refdeb To reffin 'boucle a appliquer pour chacune des référence que représente la photo
            ref = Cells(i, 2) 'Je recupere le nom du fichier "brut", dans mon exemple "1 a 5"
            Set oFSO = CreateObject("Scripting.FileSystemObject")
            With oFSO
                    xxxxxxx '--> Comment je peux sélectionner le fichier "ref" qui dans mon exemple = "1 a 5" dans ton exemple tu balaye tous le dossier
                    ExtensionFichier = .GetExtensionName(FichierEnCours)
                    .CopyFile FichierEnCours, RepertoireCible & y & "." & ExtensionFichier 'colle le fichier avec le nom y
            End With
        Next y
    Next i
    Set oFSO = Nothing:  Set FolderEnCours = Nothing

End Sub

Yop,

Aprés moulte recherche et mal de tete j'ai ce code qui marche :) Je ne pense pas que ce soit optimisé mais si ca peut aider des gens dans le futur :)

Merci Eric pour ta reponse, je ne connaissais pas du tout le monde des objets :)

Sub Ddsq()

Dim NumeroFichier As Integer
Dim oFSO As Object, FolderEnCours As Object, FichierEnCours As Object, a As Object
Dim RepertoireSource As String, RepertoireCible As String, ExtensionFichier As String
RepertoireSource = "C:\Users\Moi\Downloads\Nouveau dossier\"
RepertoireCible = "C:\Users\Moi\Downloads\Nouveau dossier\rename\"

    For i = 2 To 63 'correspond au nombre de fichier que j'ai dans mon dossier de data brut
        refdeb = Cells(i, 3) 'Correspond a la 1er ref que représente mon fichier --> 1 dans mon exemple
        reffin = Cells(i, 4) 'Correspond a la derniere ref que représente mon fichier --> 5 dans mon exemple
        For y = refdeb To reffin 'boucle a appliquer pour chacune des référence que représente la photo
            ref = Cells(i, 2) 'Je recupere le nom du fichier "brut", dans mon exemple "1 a 5"
            pho = RepertoireSource & ref
            des = RepertoireCible & y & ".jpg"
            Set oFSO = CreateObject("Scripting.FileSystemObject")
            Call oFSO.CopyFile(pho, des, True)
        Next y
    Next i
    Set oFSO = Nothing:  Set FolderEnCours = Nothing

End Sub