XL 2016 VBA pour dupliquer un fichier en X fois

[Chouki0001]

Bonjour,
J'ai un répertoire dans lequel il y a 136 fichiers portant un nom unique.
Je souhaiterais renommer ces fichiers avec de nouveaux noms.
Aussi je souhaiterais trouver une façon de dupliquer X fois un même fichier.
Exemples :
J'ai un fichier qui s'appelle Alpha. Je souhaiterais dupliquer ce fichier 48 fois afin d'avoir 49 fichiers qui s'appelleraient Alpha1; Alpha2; Alpha3, .....
J'ai un autre fichier qui s'appelle Bêta. Je souhaiterais dupliquer ce fichier 27 fois afin d'avoir 28 fichiers qui s'appelleraient Beta; Beta2; Beta3, .....
J'ai un autre fichier qui s'appelle Gamma. Je souhaiterais dupliquer ce fichier 4 fois afin d'avoir 5 fichiers qui s'appelleraient Gamma1; Gamma2; Gamma3 .....
J'ai un autre fichier qui s'appelle Delta. Je souhaiterais dupliquer ce fichier 2 fois afin d'avoir 3 fichiers qui s'appelleraient Delta1; Delta2; Delta3, .....
J'ai un autre fichier qui s'appelle Epsilon. Je souhaiterais dupliquer ce fichier 0 fois afin d'avoir 1 fichier qui s'appellerait Epsilon


L'idée, c'est d'avoir une Macro qui irait voir dans un tableau avec 2 colonnes, l'une comportant la référence et dans l'autre colonne le nombre de fois que le fichier doit être dupliquer dans le répertoire et les dupliquer.

Merci pour votre aide

Chouki

 

[yal]

Bonjour
Drôle d'idée

Sub CopieFichiers()
  Dim tbliste()
  Dim i As Integer, j As Integer
  Dim chemin As String, fSource As String, fCible As String
 
  chemin = ThisWorkbook.Path & "\"
  tbliste = Range("tb_listeFichiers").Value2
 
  For i = 1 To UBound(tbliste)
    For j = 1 To tbliste(i, 2)
      fSource = chemin & tbliste(i, 1) & ".xlsx"
      fCible = chemin & tbliste(i, 1) & j & ".xlsx"
      FileCopy fSource, fCible
    Next j
  Next i
 
End Sub

 

[job75]

Bonjour Chouki0001, yal,

Téléchargez les fichiers joints dans le même dossier et exécutez cette macro :

Sub Copier()
Dim chemin$, fso As Object, f As Object, pos%, nf$, i As Variant, n%
chemin = ThisWorkbook.Path & "\"
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
'---supprime les fichiers indexés---
For Each f In fso.GetFolder(chemin).Files
    If f.Name Like "*#.*" Then
        Workbooks(f.Name).Close False 'si le fichier est ouvert on le ferme
        Kill chemin & f.Name
    End If
Next f
'---copie les fichiers restants---
For Each f In fso.GetFolder(chemin).Files
    If f.Name <> ThisWorkbook.Name Then
        pos = InStrRev(f.Name, ".")
        nf = Left(f.Name, pos - 1)
        i = Application.VLookup(nf, Columns("A:B"), 2, 0) 'RECHERCHEV
        If IsNumeric(i) Then
            For n = 1 To i
                fso.CopyFile chemin & f.Name, chemin & nf & n & Mid(f.Name, pos)
            Next n
        End If
    End If
Next f
End Sub

A+

 

[job75]

Avec la fonction Dir c'est un peu plus rapide :

Sub Copier_fichiers()
Dim chemin$, fichier, pos%, nf$, i As Variant, n%
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin) '1er fichier du dossier
On Error Resume Next
'---supprime les fichiers indexés---
While fichier <> ""
    If fichier Like "*#.*" Then
        Workbooks(fichier).Close False 'si le fichier est ouvert on le ferme
        Kill chemin & fichier
    End If
    fichier = Dir
Wend
'---copie les fichiers restants---
fichier = Dir(chemin)
While fichier <> ""
    If fichier <> ThisWorkbook.Name Then
        pos = InStrRev(fichier, ".")
        nf = Left(fichier, pos - 1)
        i = Application.VLookup(nf, Columns("A:B"), 2, 0) 'RECHERCHEV
        If IsNumeric(i) Then
            For n = 1 To i
                FileCopy chemin & fichier, chemin & nf & n & Mid(fichier, pos)
            Next n
        End If
    End If
    fichier = Dir
Wend
End Sub

Notez que des fichiers peuvent avoir le même nom et des extensions différentes.

 

[job75]

Il faut noter cette différence entre les 2 méthodes :

- si le fichier "Gamma.xlsx" est ouvert la macro Copier fait bien la copie

- alors que la macro Copier_fichiers ne la fait pas.

 

[Chouki0001]

Bonjour à tous,
Je vous remercie pour vos contributions.
@yal : Lorsque je clique sur le bouton copier, il ne se passe absolument rien.
@job75 : La macro se lance bien par contre j'ai le meme message d'erreur qui apparait. Au début, je pensais qu'il me l'affichait pour

 

[Chouki0001]

Bonjour à tous,
Je vous remercie pour vos contributions.
@yal : Lorsque je clique sur le bouton copier, il ne se passe absolument rien.
@job75 : La macro se lance bien par contre j'ai le même message d'erreur qui apparait. Au début, je pensais qu'il me l'affichait pour les fichiers uniques, mais finalement, non il me l'a fait sur plusieurs fichiers quelque ce soit le nombre de copie demandés.

Bonjour à tous,
Je vous remercie pour vos contributions.
@yal : Lorsque je clique sur le bouton copier, il ne se passe absolument rien.
@job75 : La macro se lance bien par contre j'ai le même message d'erreur qui apparait. Au début, je pensais qu'il me l'affichait pour les fichiers uniques, mais finalement, non il me l'a fait sur plusieurs fichiers quelque ce soit le nombre de copie demandés.

 

[job75]

Bonjour Chouki0001, le forum,

Les fichiers des posts #3 et #4 doivent fonctionner sans problème.

Testez-les sans rien modifier.

Je ne vois pas pourquoi il y a ce message puisque les fichiers indexés existant sont supprimés préalablement.

A+

 

[Chouki0001]

Bonjour @job75,
Après plusieurs essais avec les deux méthodes, cela ne fonctionne toujours pas.
Pourtant je ne touche à rien. Je copie simplement mes fichiers dans votre tableau "copie fichiers", en s'assurant que le fichier "Gamma" est bien ouvert. Et il se passe absolument rien.
Désolé de vous relancer mais j’ai vraiment besoin d’un coup de main.
Merci d'avance,
Chouki.

 

[job75]

Bonjour Chouki0001,

en s'assurant que le fichier "Gamma" est bien ouvert.

Ce fichier doit normalement être fermé.

S'il est ouvert la 2ème macro (avec Dir) ne fait pas la copie, je l'ai dit au post #5 !!

A+

 

[Chouki0001]

Bonjour,
j’applique à la lettre c’est à dire que je ferme le fichier et il ne fonctionne pas
Avez vous fait un essai avec un répertoire contenant deux ou trois fichier à dupliquer ?
Merci.
Chouki

 

[job75]

Au post #1 vous avez écrit :

J'ai un fichier qui s'appelle Alpha. Je souhaiterais dupliquer ce fichier 48 fois afin d'avoir 49 fichiers qui s'appelleraient Alpha1; Alpha2; Alpha3,

Vous auriez pu remarquer aux posts #3 et #4 que le nom Alpha est placé en colonne A sans l'extension.

Puisque vous mettez les noms avec extension il faut modifier la macro en remplaçant simplement :

i = Application.VLookup(nf, Columns("A:B"), 2, 0) 'RECHERCHEV

par :

i = Application.VLookup(fichier, Columns("A:B"), 2, 0) 'RECHERCHEV

Testez les 2 fichiers joints.

 

[job75]

Notez que les 10 fichiers d'extension .jpg en fin de liste seront supprimés s'ils existent dans le dossier.

En effet leurs noms (sans extension) se terminent par des chiffres.

 

[Chouki0001]

Bonjour Job75,
Toutes mes excuses quant aux consignes peux explicatives données.
Ça fonctionne super bien, un grand merci !
Chouki.