Modifier plusieurs fichiers à partir d'un modèle

Question

Il y a un petit moment on m'avait aidé ici a faire une macro qui permettait de transférer un modèle de fichier en prenant l'intégralité des informations saisies d'un autre fichier. Cette macro qui fonctionne toujours me permet de faire bénéficier un ancien fichier d'éventuelles nouvelles macro présentes sur le modèle. Cette macro est la suivante : Option Explicit Sub BasculeOldversNew() ' BasculeOldversNew Macro Dim FPath As String Dim FichaOuvrir Dim W1 As Workbook Dim W2 As Workbook Dim j As Integer Dim x As Integer ' Déterminer le répertoire courant FPath = ThisWorkbook.Path & "\" ChDir FPath ' Ne pas rafraichir l'écran pour accélerer la macro Application.ScreenUpdating = False ' Ne pas afficher les messages d'alerte Application.DisplayAlerts = False ' Définir le fichier de Destination Set W1 = ActiveWorkbook ' Ouvrir une boite de Dialogue pour permettre à l'utilisateur de choisir le fichier à ouvrir ... FichaOuvrir = Application.GetOpenFilename _ (Title:="Merci de choisir le fichier Excel à ouvrir", _ FileFilter:="Excel Files *.xls (*.xls),") If FichaOuvrir = False Then MsgBox "Pas de fichier sélectionné ... ", vbExclamation, "Oups!!!" Exit Sub Else ' Ouvrir le fichier Workbooks.Open Filename:=FichaOuvrir End If ' Définir le fichier Source Set W2 = ActiveWorkbook 'Bascule les dates et les codes compte en compta W2.Worksheets("COMPTE1").Range("A8:B" & Range("A65536").End(xlUp).Row).Copy W1.Worksheets("COMPTE1").Range("A8").PasteSpecial Paste:=xlPasteFormulas 'Bascule les libellés des écritures comptables W2.Worksheets("COMPTE1").Range("D8:D" & Range("D65536").End(xlUp).Row).Copy W1.Worksheets("COMPTE1").Range("D8").PasteSpecial Paste:=xlPasteFormulas 'Copie le nom, le numéro de dossier et la mesure de protection W2.Worksheets("COMPTE1").Range("B2:B4").Copy W1.Worksheets("COMPTE1").Range("B2").PasteSpecial Paste:=xlPasteFormulas 'Copie la date de la comptabilité W2.Worksheets("COMPTE1").Range("A6").Copy W1.Worksheets("COMPTE1").Range("A6").PasteSpecial Paste:=xlPasteFormulas 'Bascule les écritures comptables Colonnes F à S (soit de 6 à 19) For j = 6 To 19 x = W2.Worksheets("COMPTE1").Cells(65536, j).End(xlUp).Row If x &gt; 8 Then W2.Worksheets("COMPTE1").Range(Cells(8, j), Cells(x, j)).Copy W1.Worksheets("COMPTE1").Cells(8, j).PasteSpecial Paste:=xlPasteFormulas End If Next j 'Bascule les libellés des comptes W2.Worksheets("COMPTE1").Range("AL6:AL19").Copy W1.Worksheets("COMPTE1").Range("AL6").PasteSpecial Paste:=xlPasteFormulas 'Bascule les intitulés de compte W2.Worksheets("COMPTE1").Range("AM6:AO19").Copy W1.Worksheets("COMPTE1").Range("AM6").PasteSpecial Paste:=xlPasteFormulas 'Bascule la numérotation des comptes W2.Worksheets("COMPTE1").Range("AP6:AP19").Copy W1.Worksheets("COMPTE1").Range("AP6").PasteSpecial Paste:=xlPasteFormulas 'Bascule les soldes de début d'exercice des comptes W2.Worksheets("COMPTE1").Range("AQ6:AQ19").Copy W1.Worksheets("COMPTE1").Range("AQ6").PasteSpecial Paste:=xlPasteFormulas 'Bascule les intitulés dans les dépenses W2.Worksheets("COMPTE1").Range("AV6:AV27").Copy W1.Worksheets("COMPTE1").Range("AV6").PasteSpecial Paste:=xlPasteFormulas 'Bascule les intitulés dans les ressources W2.Worksheets("COMPTE1").Range("BK6:Bk28").Copy W1.Worksheets("COMPTE1").Range("BK6").PasteSpecial Paste:=xlPasteFormulas 'Fermer le fichier Source W2.Close ' Rétablir la configuration initiale Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Le seul inconvénient de cette macro c'est que je suis obligé de la faire tourner individuellement... Je voulais juste savoir si il y avait quelconque possibilité d'adapter cette macro pour qu'elle recopie le modèle en question sur plusieurs fichiers présents dans un dossier. En gros la macro s'exécuterait depuis le modèle on lui donne le dossier source à remplacer elle recopie sur la base de la macro susmentionnées, et elle enregistre le nouveau fichier dans le dossier source en écrasant le fichier avec le nom déjà présent dans le fichier source. Je ne sais pas si c'est compréhensible... Je ne sais pas du tout comment faire, le chemin des fichiers à modifier serait le : C:\CRG Je vous remercie par avance pour votre aide :)...

Invité · Answer

Tu trouveras ci-dessous ton code modifié pour opérer dans un dossier entier, par mesure de sécurité je fais une backup de l'ancien fichier avant de le remplacer Sub BasculeOldversNew() ' BasculeOldversNew Macro Dim FPath As String Dim FichaOuvrir Dim W1 As Workbook, W2 As Workbook Dim w2Name As String, w2Back As String Dim j As Integer Dim x As Integer ' Déterminer le répertoire courant FPath = ChoixDossier("C:\CRG\") ChDir FPath ' Ne pas rafraichir l'écran pour accélerer la macro Application.ScreenUpdating = False ' Ne pas afficher les messages d'alerte Application.DisplayAlerts = False ' Définir le fichier de Destination Set W1 = ActiveWorkbook ' Ouvrir une boite de Dialogue pour permettre à l'utilisateur de choisir le fichier à ouvrir ... FichaOuvrir = Dir(FPath & "*.xls") Do While FichaOuvrir &lt;&gt; "" ' Définir en ouvrant le fichier 2 Set W2 = Workbooks.Open(Filename:=FichaOuvrir) w2Name = W2.Name 'Bascule les dates et les codes compte en compta W2.Worksheets("COMPTE1").Range("A8:B" & Range("A65536").End(xlUp).Row).Copy W1.Worksheets("COMPTE1").Range("A8").PasteSpecial Paste:=xlPasteFormulas 'Bascule les libellés des écritures comptables W2.Worksheets("COMPTE1").Range("D8:D" & Range("D65536").End(xlUp).Row).Copy W1.Worksheets("COMPTE1").Range("D8").PasteSpecial Paste:=xlPasteFormulas 'Copie le nom, le numéro de dossier et la mesure de protection W2.Worksheets("COMPTE1").Range("B2:B4").Copy W1.Worksheets("COMPTE1").Range("B2").PasteSpecial Paste:=xlPasteFormulas 'Copie la date de la comptabilité W2.Worksheets("COMPTE1").Range("A6").Copy W1.Worksheets("COMPTE1").Range("A6").PasteSpecial Paste:=xlPasteFormulas 'Bascule les écritures comptables Colonnes F à S (soit de 6 à 19) For j = 6 To 19 x = W2.Worksheets("COMPTE1").Cells(65536, j).End(xlUp).Row If x &gt; 8 Then W2.Worksheets("COMPTE1").Range(Cells(8, j), Cells(x, j)).Copy W1.Worksheets("COMPTE1").Cells(8, j).PasteSpecial Paste:=xlPasteFormulas End If Next j 'Bascule les libellés des comptes W2.Worksheets("COMPTE1").Range("AL6:AL19").Copy W1.Worksheets("COMPTE1").Range("AL6").PasteSpecial Paste:=xlPasteFormulas 'Bascule les intitulés de compte W2.Worksheets("COMPTE1").Range("AM6:AO19").Copy W1.Worksheets("COMPTE1").Range("AM6").PasteSpecial Paste:=xlPasteFormulas 'Bascule la numérotation des comptes W2.Worksheets("COMPTE1").Range("AP6:AP19").Copy W1.Worksheets("COMPTE1").Range("AP6").PasteSpecial Paste:=xlPasteFormulas 'Bascule les soldes de début d'exercice des comptes W2.Worksheets("COMPTE1").Range("AQ6:AQ19").Copy W1.Worksheets("COMPTE1").Range("AQ6").PasteSpecial Paste:=xlPasteFormulas 'Bascule les intitulés dans les dépenses W2.Worksheets("COMPTE1").Range("AV6:AV27").Copy W1.Worksheets("COMPTE1").Range("AV6").PasteSpecial Paste:=xlPasteFormulas 'Bascule les intitulés dans les ressources W2.Worksheets("COMPTE1").Range("BK6:Bk28").Copy W1.Worksheets("COMPTE1").Range("BK6").PasteSpecial Paste:=xlPasteFormulas 'Fermer le fichier Source W2.Close ' Créer une backup de l'ancien fichier w2Back = Replace(w2Name, ".xls", "_bck.xls") Name FPath & w2Name As FPath & w2Back ' Enregistrer une copie de ce fichier sous le nom de l'ancien W1.SaveCopyAs FPath & w2Name ' Fichier suivant FichaOuvrir = Dir() Loop ' Rétablir la configuration initiale Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub @+...