XL 2016 VBA: Copier des feuilles d'un fichier dans un autre

Aloha

XLDnaute Accro
Bonsoir,

J‘ai besoin d‘une aide en VBA.
Voici de quoi il s‘agit:
J‘ai 2 fichiers:
* le fichier source (fs): il contient 3 feuilles présentant la même structure.
Leur nom: AB, CD, EF
* le fichier destination (fd): il contient 3 feuilles: AB, EF et Modèle

La tâche: copier, feuille par feuille, les données du fs dans la feuille correspondante dans fd, dans la première ligne libre, en se basant sur la colonne A

Lorsqu‘il n‘y a pas encore dans fd une feuille correspondant à une feuille dans fs (dans le cas en espèce la feuille CD), il faut prendre la feuille Modèle, faire une feuille pour la feuille correpondante de fs, et lui donner le même nom que dans fs.

J‘ai enregistré une macro qui fait l‘opération, mais seulement pour une seule feuille de fs, à condition qu‘elle existe déjà dans fd. J‘ai besoin d‘une macro qui copie d’elle-même autant de feuilles qu‘il y en a dans fs.

Dans une deuxième étape il y a plus d‘un fs et fd et la macro doit copier du bon fs dans le bon fd.

L‘emplacement des fichiers (pour que la macro sache les trouver):
fs: D: Exemple:A copier
fd: D: Exemple:Fichiers destination

J‘espère m‘être exprimé d‘une façon compréhensible.

Bonne nuit
Aloha
 

Pièces jointes

  • Fichier cible.xls
    64 KB · Affichages: 53
  • Fichier source.xls
    61.5 KB · Affichages: 45
Dernière édition:

Staple1600

XLDnaute Barbatruc
Bonsoir le fil, le forum

Une première ébauche (donc incomplète)
Macro à copier dans Fichier cible.xls
VB:
Sub Test()
Dim Cible As Workbook, Source As Workbook, Ws As Worksheet
Application.ScreenUpdating = False
Set Cible = ThisWorkbook
'corriger le chemin du dossier contenant le fichier
Set Source = Application.Workbooks.Open("C:\STAPLE1600\Fichier source.xls")
For i = 1 To Cible.Sheets.Count
Set Ws = Nothing
On Error Resume Next
Set Ws = Source.Worksheets(Cible.Worksheets(i).Name)
On Error GoTo 0
    If TypeName(Ws) <> "Nothing" Then
        With Ws
        .Range(.Cells(2, 1), .Cells(Rows.Count, 3).End(3)).Copy Cible.Worksheets(i).Cells(Rows.Count, 1).End(3)(2)
        End With
    End If
Next i
Application.CutCopyMode = False
Source.Close False
End Sub
NB: Cette version copie uniquement les données des feuilles avec le même nom dans les deux classeurs.
 

Aloha

XLDnaute Accro
Bonjour,
Je viens seulement de remarquer le N.B.
La macro ne crée donc pas une nouvelle feuille pour celle qui n'existe pas encore. Il faudrait un petit bout de plus pour parfaire la tâche.

Qui plus est, j'avais oublié que le code doit être situé dans un troisième fichier qui s'appelle "Macros" et qui se trouve dans D:Exemple. Pourrais-tu modifier le code légèrement pour en tenir compte?
Bonne journée
Aloha
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Bonjour le fil, le forum

Tout était dit le départ camarade :rolleyes:
Une première ébauche (donc incomplète)
Contrairement à toi:D
Qui plus est, j'avais oublié que le code doit être situé dans un troisième fichier qui s'appelle "Macros" et qui se trouve dans D:Exemple
Tu disais avoir besoin d'une aide en VBA
C'est donc ce que j'ai fait: te fournir une base VBA pour aller plus loin ;)
 

Staple1600

XLDnaute Barbatruc
Bonjour le fil, le forum

@Aloha
A partir de ma base , je suis donc allé plus loin ;)
Et il semblerait que cela fonctionne.
(Le code VBA est à mettre dans Fichier source et les deux fichiers doivent être ouverts)
VB:
Sub Aloha_V2()
Dim WS As Worksheet
Dim Cible As Workbook
Set Cible = Workbooks("Fichier cible.xls")
Application.ScreenUpdating = False
    For Each WS In ThisWorkbook.Worksheets
        If SheetExists(WS.Name, Cible) Then
        WS.Range(WS.Cells(2, 1), WS.Cells(Rows.Count, 3).End(xlUp)).Copy Cible.Worksheets(WS.Name).Cells(Rows.Count, 1).End(3)(2)
        Application.CutCopyMode = False
        Else
        Cible.Sheets("Modèle").Copy after:=Cible.Sheets(Cible.Sheets.Count)
        Cible.Sheets("Modèle (2)").Name = WS.Name
        WS.Range(WS.Cells(2, 1), WS.Cells(Rows.Count, 3).End(xlUp)).Copy Cible.Worksheets(WS.Name).Cells(Rows.Count, 1).End(3)(2)
        Application.CutCopyMode = False
        End If
    Next WS
Application.DisplayAlerts = False
Cible.Close True
End Sub
Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
SheetExists = Not sht Is Nothing
End Function
 

Aloha

XLDnaute Accro
Rebonjour,

Merci beaucoup!
Je suis d'ailleurs arrivé à modifier ton code de telle sorte qu'il ouvre les deux fichiers et que la macro est située dans le fichier "Macros".
Comme ton nouveau code présuppose les fichiers ouverts il faut donc importer une partie du 1er code.
Bonne journée
Aloha
 

Aloha

XLDnaute Accro
Pourquoi compliquer? C'est plutôt simplifier la tâche que de faire ouvrir les fichiers par la macro, non?

J'ai d'ailleurs réussi à adapter ta dernière macro pour que cette tâche supplémentaire soit exécutée.

Ce que je n'ai pas encore réussi: trier les feuilles alphabétiquement, déplacer la feuille "Modèle" à la fin des feuilles, et puis la cacher aussi.

Bonne après-midi
Aloha
 

Aloha

XLDnaute Accro
Bonjour,

Je pars d'une situation réelle où les macros se trouvent dans un autre fichier.
Mon exemple que j'ai présenté est fortement simplifié.
Lorsque j'aurai encore réussi le tri des fiches et réussi à étendre ton code pour qu'il fonctionne dans un environnement où il y a plus d'un fichier source et plus d'un fichier cible, j'adapterai le code au fichier réel.
Voici d'ailleurs le code modifié pour qu'il ouvre les fichiers. Il fonctionne comme il faut sauf qu'il ne fait pas encore le tri.

Sub Aloha_V2()
Dim WS As Worksheet, Cible As Workbook, Source As Workbook
Set Cible = Application.Workbooks.Open("[...]")
Set Source = Application.Workbooks.Open("[...]")
Application.ScreenUpdating = False
For Each WS In Source.Worksheets

If SheetExists(WS.Name, Cible) Then
WS.Range(WS.Cells(2, 1), WS.Cells(Rows.Count, 3).End(xlUp)).Copy Cible.Worksheets(WS.Name).Cells(Rows.Count, 1).End(3)(2)
Application.CutCopyMode = False
Else
Cible.Sheets("Modèle").Copy after:=Cible.Sheets(Cible.Sheets.Count - 1)

Cible.Sheets("Modèle (2)").Move after:=Cible.Sheets(Cible.Sheets.Count)
Cible.Sheets("Modèle (2)").Name = WS.Name

WS.Range(WS.Cells(2, 1), WS.Cells(Rows.Count, 3).End(xlUp)).Copy Cible.Worksheets(WS.Name).Cells(Rows.Count, 1).End(3)(2)
Application.CutCopyMode = False
End If
Next WS
Application.DisplayAlerts = False
Cible.Close True
Source.Close False
End Sub
Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = Source
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
SheetExists = Not sht Is Nothing
End Function


A+
Aloha
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re

Pour le tri, il y a tout ce qu'il faut dans les archives du forum.

PS1: Dans une situation réelle*, je pense que ma macro ne pourrait pas ne pas planter un de ces jours sans lune.
(*gros volumes de données)


PS2: Une suggestion en passant,:
@Aloha (sachant que tu es inscris depuis 10 ans) , peut-être est-il temps d'utiliser les balises BBCODE pour rendre ton message plus agréable à lire ;)
(cf ma signature)
 

Aloha

XLDnaute Accro
Re,

Même si je suis inscrit depuis si longtemps, je ne pense pas avoir déjà posté du code!

J'ai d'ailleurs réussi à faire le tri et à cacher la feuille modèle. Je suis sûr qu'il y a plus simple, mais cela fonctionne.

Ce qui me manque encore maintenant c'est que le code puisse manipuler autant de fichiers source qui se trouvent dans le dossier et ouvrir les fichiers cible correspondants pour y copier les données.

Comme c'est une nouvelle situation je vais créer un nouveau thème.

Pourquoi crains-tu que ton code puisse planter? La quantité des données à copier est limitée à moins de 700 valeurs par feuille source.

VB:
Sub Copier_les_saisies()
Dim WS As Worksheet, Cible As Workbook, Source As Workbook
Set Cible = Application.Workbooks.Open("...")
Set Source = Application.Workbooks.Open("...")
Application.ScreenUpdating = False
    For Each WS In Source.Worksheets

        If SheetExists(WS.Name, Cible) Then
        WS.Range(WS.Cells(2, 1), WS.Cells(Rows.Count, 3).End(xlUp)).Copy Cible.Worksheets(WS.Name).Cells(Rows.Count, 1).End(3)(2)
        Application.CutCopyMode = False
        Else
        Cible.Sheets("Modèle").Visible = True
        Cible.Sheets("Modèle").Copy after:=Cible.Sheets(Cible.Sheets.Count)
        Cible.Sheets("Modèle (2)").Name = WS.Name
        Cible.Sheets("Modèle").Move after:=Cible.Sheets(Cible.Sheets.Count - 1)
        Cible.Sheets("Modèle").Visible = False

        WS.Range(WS.Cells(2, 1), WS.Cells(Rows.Count, 3).End(xlUp)).Copy Cible.Worksheets(WS.Name).Cells(Rows.Count, 1).End(3)(2)
        Application.CutCopyMode = False
        End If
    Next WS

    Call Trier_les_feuilles
Application.DisplayAlerts = False
Cible.Close True
Source.Close False
End Sub

Sub Trier_les_feuilles()
'
  Dim i As Integer
  Dim j As Integer
  For i = 1 To Sheets.Count
  For j = 1 To Sheets.Count - 1
  If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then _
  Sheets(j).Move after:=Sheets(j + 1)
Next j
Next i
End Sub

Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = Source
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
SheetExists = Not sht Is Nothing
End Function

A+
Aloha
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re

Ce qui me manque encore maintenant c'est que le code puisse manipuler autant de fichiers source qui se trouvent dans le dossier et ouvrir les fichiers cible correspondants pour y copier les données.
Idem tu trouveras tout ce qu'il faut dans les archives du forum
Et les solutions sont multiples:
Application.FileDialog(msoFileDialogFolderPicker)
ou encore
CreateObject("Shell.Application"). BrowseForFolder

PS:
J'ai d'ailleurs réussi à faire le tri et à cacher la feuille modèle. Je suis sûr qu'il y a plus simple, mais cela fonctionne.
Tu parles du tri ou de toute la procédure?
 

Discussions similaires