Dupliquer des fichiers VBA

Bonsoir,

Nouvelle question : Peut-on dupliquer un fichier à partir d'une macro VBA ? Je précise. J'ai un fichier de départ que je dois utiliser pour créer et renommer 10 autres fichiers. Du coup, je voulais simplement renommer le dossier original et lui attribuer un nom différent pour les dix fichiers que je veux créer à partir du fichier de départ. J'ai écrit le code suivant :

Sub RenameFile()

Dim OldName As String
Dim NewName As String
Dim j As Integer
Dim repertoire As String
Dim repertoiredest As String
Dim fichier As String

repertoire = "..." 'Chemin du fichier de départ
repertoiredest = "..." 'Chemin pour les fichiers créés

fichier = Dir(repertoire, 0)

For j = 0 to 9 
OldName = "..."
NewName = "..."

Name OldName As NewName
Next j

End Sub

(J'ai recopié mon code à la main, ne faites pas attention aux fautes de frappe) Mon problème est donc le suivant, lorsque j'exécute le programme, le premier se copie et se renomme parfaitement mais du coup lorsque la boucle s'exécute la deuxième fois, le fichier de départ n'est plus dans le dossier original. J'en ai conclus que mon code faisait un couper-coller en le renommant du fichier original. Du coup, je me demandais s'il était possible de dupliquer le fichier original autant de fois que souhaité pour ensuite renommer chaque fichier dans une boucle. Quelqu'un peut-il m'aiguiller ?

Merci d'avance

Bonjour,

Faire une recherche sur SaveCopyAs

A+

Option Explicit

Sub RenameFile()
    Dim OldName As String, NewName As String
    Dim fd As FileDialog, dossier As String
    Dim table() As String, j As Byte, topFolder As String

    ' Dossier racine
    topFolder = ThisWorkbook.Path
    For j = 1 To 10
        ' S'ils n'existent pas déjà on crée les sous-dossiers 1 à 10
        dossier = topFolder & "\dossier" & Right("00" & Trim(str(j)), 2)
        If Dir(dossier, vbDirectory) <> "" Then Exit For
        MkDir topFolder & "\dossier" & Right("00" & Trim(str(j)), 2)
    Next j

    ' On sélectionne le fichier à dupliquer
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls*?"
        .Title = "Sélectionner le fichier à dupliquer."
        .AllowMultiSelect = False
        .InitialFileName = "C:\"
        If .Show = True Then OldName = .SelectedItems(1)
    End With

    ' On extrait la racine du nom du fichier
    table = Split(OldName, "\")
    table = Split(table(UBound(table)), ".")

    ' et on duplique le fichier dix fois
    For j = 1 To 10
        NewName = topFolder _
        & "\dossier" & Right("00" & Trim(str(j)), 2) _
        & "\" & table(0) & Right("00" & Trim(str(j)), 2) _
        & "." & table(1)
        FileCopy OldName, NewName
    Next j
    MsgBox "Le fichier " & OldName & " a été dupliqué dans les sous-dossiers " & Chr(34) & "dossier0X" & Chr(34) & " du dossier courant.", vbInformation + vbOKOnly, "Traitement terminé"
End Sub

Bonjour,

Merci beaucoup pour l'aide. J'ai tout de même une question : Faut-il obligatoirement créer des sous-dossiers pour stocker chacune des copies du fichier original ?

Dans mon cas, pour manipuler ensuite les copies du fichier, ce serait plus simple de créer les copies dans le même dossier que l'original. D'ailleurs, concernant le code que vous m'avez transmis, il ne me copie pas exactement le fichier. Lorsque j'ouvre les sous-dossiers, les fichiers copiés ne sont plus des fichiers .xlsm. Cela doit venir du NewName que je donne aux fichiers mais je n'ai compris comment modifier le code pour que le nouveau nom des fichiers soit correct. Pour exemple, l'une des copies du fichier est renommé : V03.I dans le sous-dossier 3.

Merci d'avance,

Bonne journée

Les choses n'étaient pas assez claires pour moi au départ. Il faut tout mettre dans le dossier contenant la macro ou dans le dossier contenant le fichier à dupliquer ?

Si c'est dans le dossier contenant l'original, c'est encore plus facile. Ce sera ça :

Option Explicit

Sub RenameFile()
    Dim OldName As String, NewName As String
    Dim fd As FileDialog, dossier As String
    Dim table() As String, j As Byte

    ' On sélectionne le fichier à dupliquer
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls*?"
        .Title = "Sélectionner le fichier à dupliquer."
        .AllowMultiSelect = False
        .InitialFileName = "C:\"
        If .Show = True Then OldName = .SelectedItems(1)
    End With

    ' On extrait le nom du fichier et son chemin
    table = Split(OldName, "\")
    dossier = Left(OldName, Len(OldName) - Len(table(UBound(table))))
    table = Split(table(UBound(table)), ".")

    ' et on duplique le fichier dix fois
    For j = 1 To 10
        NewName = dossier _
        & table(0) & Right("00" & Trim(str(j)), 2) _
        & "." & table(1)
        FileCopy OldName, NewName
    Next j
    MsgBox "Le fichier " & OldName & " a été dupliqué dix fois dans le dossier contenant l'original.", vbInformation + vbOKOnly, "Traitement terminé"
End Sub

Oui, il faut tout mettre dans le dossier du fichier à dupliquer. Désolé de m'être mal expliqué

Je viens de modifier.

Merci beaucoup pour ton aide, j'ai adapté ton code et cela fonctionne !

Merci encore, bonne journée