XL 2016 Copier des données d'un fichier dans un fichier identique

Aloha

XLDnaute Accro
Bonjour,

Toujours dans le même contexte (projet) que mes derniers thèmes:

Comment puis-je dire à Excel de copier des données (F6:AC66) des feuilles d'un fichier source dans un fichier destination identique, sauf , sauf les formules qui font d'autres calculs que dans le fichier source?
La tâche d'Excel est concrètement:
Ouvrir le fichier destination dont le nom est le même que celui du fichier source +"new" à la fin
Prendre, dans le fichier source, la feuille "Nom A", copier F6:AC66, et coller dans la même aire de "Nom A" du fichier de destination.
Puis, copier la même aire de la feuille "Nom B" du fichier source et coller dans "Nom B" du fichier de destination.
Il y a 3 fiches qui ne doivent pas être copiées: AB, CD, EF (noms fictifs).

Je suppose qu'il ne faut pas grand-chose comme code pour accomplir cette tâche.

Bien à vous
Aloha
 

Pièces jointes

  • Janvier 2018 BP.xlsx
    56.8 KB · Affichages: 18
  • Janvier 2018 BP new.xlsx
    29.5 KB · Affichages: 19

Patrice33740

XLDnaute Impliqué
Re,

Essaies (les 2 fichiers doivent être ouverts avant de lancer la macro) :
Option Explicit
VB:
Sub test()
Dim wbkSrc As Workbook
Dim wbkDst As Workbook
Dim nom As String
Dim ext As String
Dim adr As String

  nom = "Janvier 2018 BP.xlsx"
  Set wbkSrc = Workbooks(nom)
  ext = Mid(nom, InStrRev(nom, "."))
  nom = Mid(nom, 1, InStrRev(nom, ".") - 1) & " new" & ext
  Set wbkDst = Workbooks(nom)
  adr = "F6:AC66"
  nom = "Nom A"
  'Copier toute la plage (pour copier les formats, commentaires, validations)
  wbkSrc.Worksheets(nom).Range(adr).Copy wbkDst.Worksheets(nom).Range(adr)
  'Copier les valeurs (résultat des formules)
  wbkDst.Worksheets(nom).Range(adr).Value = wbkSrc.Worksheets(nom).Range(adr).Value
  nom = "Nom B"
  wbkSrc.Worksheets(nom).Range(adr).Copy wbkDst.Worksheets(nom).Range(adr)
  wbkDst.Worksheets(nom).Range(adr).Value = wbkSrc.Worksheets(nom).Range(adr).Value

End Sub

Si il n'y a pas besoin de copier les formats, commentaires, .. supprimer les 2 lignes :
VB:
  wbkSrc.Worksheets(nom).Range(adr).Copy wbkDst.Worksheets(nom).Range(adr)
 

Aloha

XLDnaute Accro
Bonjour,
Merci pour le code
Le problème est qu'au moins -si possible aussi le nom du fichier- le nom des feuilles doit être flexible. Je dois faire la même opération sur 10 fichiers avec quelque 120 feuillets, et il n'y a pas deux fois le même nom.
Bonne journée
Aloha
 
Dernière édition:

Patrice33740

XLDnaute Impliqué
Qu'entends-tu par flexible ???
Là, c'est flexible, il suffit de modifier les variables
Ça peut être automatisé, mais Excel n'est pas devin, il faut connaitre la règle qui permet de reconnaitre les fichiers et celle qui permet de reconnaître les feuilles
 

Aloha

XLDnaute Accro
Par flexible j'entends qu'il ne faut pas que les noms des feuilles soient inscrits dans la macro, mais qu'Excel reçoive l'instruction de copier les données de chaque feuille du fichier source dans sa sosie dans le fichier destination.
En ce qui concerne les fichiers, je m'imagine deux possibilités: une semi-automatique où le fichier est déterminé p.ex. en inscrivant son nom dans une cellule ou bien en étant invité par la macro à choisir le fichier à ouvrir, et une automatique où il ouvre l'un après l'autre tous les fichiers qui se trouvent à cet effet dans un dossier nommé ToBeCopied.
Le fichier destination peut être désigné par la macro sur base du nom de la source (nom destination = nom source +"new").
 

Jacky67

XLDnaute Barbatruc
Bonjour,
Pj à tester
Dans l'exemple le fichier source et destination sont dans le même répertoire.
Cette exemple copie du classeur source la plage F6:AC66 vers le classeur destination de toutes les feuilles présentent dans le classeur destination dont le nom est identique dans le classeur source.
VB:
Sub CopierJJ()
Dim Sh As Worksheet
Application.ScreenUpdating = False
Workbooks.Open Filename:=ThisWorkbook.Path & "\Janvier 2018 BP new.xlsm"
For Each Sh In ActiveWorkbook.Worksheets
  On Error Resume Next
  ThisWorkbook.Sheets(Sh.Name).[F6:AC66].Copy
  If Err = 0 Then ActiveWorkbook.Sheets(Sh.Name).[f6].PasteSpecial Paste:=xlPasteValues
  On Error GoTo 0
Next
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.ScreenUpdating = True
End Sub
 

Pièces jointes

  • Janvier 2018 BP.xlsm
    69.3 KB · Affichages: 17
Dernière édition:

Patrice33740

XLDnaute Impliqué
Re,

Essaies :
VB:
Option Explicit
Sub Copier()
Dim wbkSrc As Workbook
Dim wbkDst As Workbook
Dim wshSrc As Worksheet
Dim wshDst As Worksheet
Dim nomSrc As String
Dim nomDst As String
Dim adr As String
Dim rép As String
  'Plage à copier
  adr = "F6:AC66"
  'Répertoite des fichiers
  rép = ThisWorkbook.Path & "\ToBeCopied\" 'Ou autre à adapter
  'Nom du premier fichier destination
  nomDst = Dir(rép & "* new.xlsx")
  'Arrêter l'actualisation de l'affichage
  Application.ScreenUpdating = False
  'Explorer le répertoire
  Do While Len(nomDst) > 0
    '- ouvrir le fichier source
    nomSrc = Replace(nomDst, " new", "")
    On Error Resume Next
    Set wbkSrc = Workbooks.Open(rép & nomSrc)
    On Error GoTo 0
    If Not wbkSrc Is Nothing Then
      '- si le fichier source existe, ouvrir le fichier destination
      Set wbkDst = Workbooks.Open(rép & nomDst)
      '- explorer toutes les feuilles sources
      For Each wshSrc In wbkSrc.Worksheets
        '- définir la feuille destination
        On Error Resume Next
        Set wshDst = wbkDst.Worksheets(wshSrc.Name)
        On Error GoTo 0
        If Not wshDst Is Nothing Then
          ' - si elle exite copier les formats, commentaires, validations et formules
          wshSrc.Range(adr).Copy wshDst.Range(adr)
          ' - et copier les valeurs
          wshDst.Range(adr).Value = wshSrc.Range(adr).Value
        End If
        Set wshDst = Nothing
      Next wshSrc
      wbkDst.Close True
      wbkSrc.Close False
    End If
    'nom du fichier destination suivant
    nomDst = Dir()
  Loop
  'Rétablir l'actualisation de l'affichage
  Application.ScreenUpdating = True
End Sub
 

Pièces jointes

  • Aloha_Copies.xlsm
    18.1 KB · Affichages: 11

Discussions similaires