Se connecter avec
S'enregistrer | Connectez-vous

[Excel :: Macro VBA] Copier un fichier excel et le renommer

Dernière réponse : dans Programmation

Bonjour,

J'ai un fichier Excel avec plusieurs Sheets. Je voudrais pouvoir le copier (contenu et forme) et enregistrer cet copie sous un autre nom.

Je pensais résoudre ce problème en créant un nouveau fichier et en y collant le contenu et la forme du fichier initiale. J'ai trouvé comment créer un nouveau fichier Excel mais je ne sais pas comment copier le contenu et la forme de mon fichier initiale vers le nouveau. Quelqu'un sait-il comment faire?

Merci,

Laurent

Autres pages sur : excel macro vba copier fichier excel renommer

Lassé par la pub ? Créez un compte

oui ça je sais faire, voilà ce que ce cela donne...

  1. Sub Ini_RA()
  2. '
  3. ' Ini_RA Macro
  4. ' Macro recorded 18/07/2006 by Laurent
  5. '
  6.     Dim nb As Integer
  7.     nb = 15 'Session number
  8.  
  9.     Dim Counter As Integer 'Counter variable
  10.     Dim PourcentageEffectue As Single 'Pourcentage progress bar variable
  11.  
  12.     'Create a new Workbook named RA.xls  
  13.     Workbooks.Add
  14.     ActiveWorkbook.SaveAs Filename:= _
  15.         "C:\Temp\RA.xls" _
  16.         , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
  17.         ReadOnlyRecommended:=False, CreateBackup:=False
  18.  
  19.     'Create and name sheets
  20.     Dim i, j As Integer
  21.     For i = 4 To nb
  22.         j = i - 1
  23.         Sheets.Add
  24.         Sheets("Sheet" & i).Move After:=Sheets(j)
  25.         Sheets("Sheet" & i).Name = "Session" & i
  26.     Next i
  27.     Sheets("Sheet1").Name = "Session1"
  28.     Sheets("Sheet2").Name = "Session2"
  29.     Sheets("Sheet3").Name = "Session3"
  30.     Sheets("Session3").Move After:=Sheets(2)
  31.  
  32.     'Copy model from Copy of RA.xls
  33.     Windows("Copy of RA.xls").Activate
  34.     Sheets("Session1").Select
  35.     Cells.Select
  36.     Selection.Copy
  37.     Windows("RA.xls").Activate
  38.     Dim k As Integer
  39.     For k = 1 To nb
  40.         Sheets("Session" & k).Select
  41.         ActiveSheet.Paste
  42.     Next k
  43.  
  44.     'Page setup
  45.     For k = 1 To nb
  46.  
  47.         'Progress Bar
  48.         Counter = k
  49.         PourcentageEffectue = Counter / nb
  50.         Call UpdateProgress(PourcentageEffectue)
  51.  
  52.         Sheets("Session" & k).Select
  53.         With ActiveSheet.PageSetup
  54.             .LeftMargin = Application.InchesToPoints(0.75)
  55.             .RightMargin = Application.InchesToPoints(0.75)
  56.             .TopMargin = Application.InchesToPoints(1)
  57.             .BottomMargin = Application.InchesToPoints(1)
  58.             .HeaderMargin = Application.InchesToPoints(0.5)
  59.             .FooterMargin = Application.InchesToPoints(0.5)
  60.             .PrintHeadings = False
  61.             .PrintGridlines = False
  62.             .PrintComments = xlPrintNoComments
  63.             .PrintQuality = 300
  64.             .CenterHorizontally = False
  65.             .CenterVertically = False
  66.             .Orientation = xlLandscape
  67.             .Draft = False
  68.             .PaperSize = xlPaperA4
  69.             .FirstPageNumber = xlAutomatic
  70.             .Order = xlDownThenOver
  71.             .BlackAndWhite = False
  72.             .Zoom = False
  73.             .FitToPagesWide = 1
  74.             .FitToPagesTall = 1
  75.             .PrintErrors = xlPrintErrorsDisplayed
  76.         End With
  77.     Next k
  78.  
  79.     Windows("Mesure.xls").Activate
  80.     Sheets("Measure").Select
  81.     Unload FrmProgression2
  82. End Sub
  83.  
  84. Sub UpdateProgress(PourcentageEffectue)
  85.     With FrmProgression2
  86.         .FrameProgress2.Caption = Format(PourcentageEffectue, "0%")
  87.         .LabelProgress.Width = PourcentageEffectue * (.FrameProgress2.Width - 10)
  88.         .Repaint
  89.     End With
  90. End Sub

En ajoutant ceci pour execution plus rapide
  1. Private Sub UserForm_activate()
  2.     Application.ScreenUpdating = False
  3.     Call Ini_RA
  4.     Application.ScreenUpdating = True
  5. End Sub


Mais n'y a-t-il pas une fonction qui permette directement de copier un fichier entier? Plutôt que de copier ces paramètres un à un?
Car en enregistrant la macro, l'execution est assez lente(peut-être aussi ai-je mal optimisé mon code...)

En fait j'ai été confronté au mêle problème pour le fichier sur lequel je travaille en ce moment (et pour lequel j'ai également demandé de l'aide).

Voici mon code (je l'édite un peu pour retirer les morceaux qui te seront inutiles) en espérant que cela te facilite la tâche) :

  1. Sub copiersousunautrenom()
  2.  
  3. ActiveWorkbook.Save
  4. 'ça c'est pour ne pas perdre le travail effectué sous ton fichier d'origine avec le nom d'origine, ça paraît idiot mais je l'avais pas mis au début.
  5.  
  6.  
  7. jour = Day(Now) & "_" & Month(Now) & "_" & Year(Now)
  8. monfichier = "C:\DOSSIER\" & Sheets("feuil1").Range("A1").Value & " " & jour
  9.  
  10. 'ça c'est pour définir le nom de ta copie, ici elle prendra le nom de ta cellule A1 feuille 1 + jour - mois - année
  11.  
  12.  
  13. If Dir(monfichier & ".xls") <> "" Then
  14. MsgBox ("Un fichier de ce nom existe déjà, veuillez le supprimer/déplacer avant nouvelle copie")
  15. Else
  16. monfichier = monfichier & ".xls"
  17.  
  18.     ActiveWorkbook.SaveAs Filename:= _
  19.         monfichier, _
  20.         FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
  21.         ReadOnlyRecommended:=False, CreateBackup:=False
  22.  
  23.  
  24.     Workbooks.Open Filename:= _
  25.         "C:\DOSSIER\fichier d'origine.xls"
  26. 'ça c'est si tu veux réouvrir ton fichier d'origine pour faire de nouvelles copies
  27.  
  28.         MsgBox ("Fichier créé dans C:\DOSSIER\")
  29.             End If
  30.         End Sub


Comme tu vois c'est un code tout bête mais ça devrait répondre à ta question.
Lassé par la pub ? Créez un compte

Répondre Créer un nouveau sujet