Copier coller la feuil1 de 12 classeurs
Bonjour a tous et toutes
Je suis a la recherche d'une macro pour copier toutes les feuil1 (onglet nommé au Mois) dans un seul et unique classeur.
mes 12 fichiers ce trouve dans le meme dossier.
je voudrais pourvoir regrouper ces fichier dans un seul classeur.
Merci de votre aide
Re bonjour
Je me suis peut-être pas bien exprimé.
Dans le dossier 2017, j'ai douze fichiers nommés au mois. ( janvier,février,mars,etc...)
Dans chaque fichier j'ai 3 onglets.
Je voudrais copier l'onglets feuil1 dans un seul classeur afin d'avoir un fichier au lieu de douze.
Merci beaucoup de vôtre aide
Bonjour,
Une piste qui doit probablement être adaptée !
Le code ci-dessous doit être mis dans un module standard du classeur devant récupérer les différentes valeurs des différentes feuilles. Tous les classeurs (classeurs des douze mois) doivent se trouver dans le même dossier que celui contenant la procédure, si ce n'est pas le cas, il faudra indiquer le chemin soit en dur dans le code soit à l'aide de "Application.FileDialog" :
Sub Test()
Dim Cls As Workbook
Dim Fe As Worksheet
Dim Plage As Range
Dim Tbl() As String
Dim I As Integer
Dim J As Integer
Dim Chemin As String
Dim Message As String
Application.ScreenUpdating = False
'Les fichiers sont dans le même dossier que le classeur contenant cette procédure, à adapter si différent !
Chemin = ThisWorkbook.Path & "\"
'appel de la fonction pour récupérer les noms des classeurs
Tbl = EnumFichiers(Chemin, ".xls*") 'astérisque si tous les fichiers Excel (.xls, .xlsx, .xlsm, etc...)
'si initialisé (au moins 1 classeur)
If Not (Not Tbl) Then
'boucle sur le tableau
For I = 1 To UBound(Tbl)
'évite le classeur contenant la procédure !
If Tbl(I) <> ThisWorkbook.Name Then
'ouvre le classeur
Set Cls = Workbooks.Open(Chemin & Tbl(I))
With Cls.Worksheets(1)
'contrôle qu'il y ait au moins une valeur sur la feuille
If Application.CountA(.Range(.Cells(1, 1), .Cells(.Rows.Count, .Columns.Count))) <> 0 Then
'défini la plage sur toute la première feuille du classeur
Set Plage = DefPlage(Cls.Worksheets(1))
'ajoute une feuille
Set Fe = ThisWorkbook.Worksheets.Add
'lui attribue le nom du classeurs en cours
Fe.Name = Left(Cls.Name, InStr(Cls.Name, ".") - 1)
Fe.Cells(1, 1).Resize(Plage.Rows.Count, Plage.Columns.Count).Value = Plage.Value
End If
End With
'referme
Cls.Close False
End If
Next I
End If
'affiche le message
If Message <> "" Then MsgBox Message
Application.ScreenUpdating = True
End Sub
Function EnumFichiers(Chemin As String, Extension As String) As String()
Dim TableauFichiers() As String
Dim Fichier As String
Dim I As Integer
'complète le chemin le cas échéant
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
'récupère seulement les fichiers Excel
Fichier = Dir(Chemin & "*" & Extension)
'boucle sur les fichiers du dossier
Do While (Len(Fichier) > 0)
I = I + 1: ReDim Preserve TableauFichiers(1 To I)
TableauFichiers(I) = Fichier
Fichier = Dir()
Loop
'retourne le tableau des noms de fichiers
EnumFichiers = TableauFichiers()
End Function
Function DefPlage(Fe As Worksheet, Optional L As Long = 1, Optional C As Long = 1) As Range
On Error GoTo Fin
With Fe
Set DefPlage = .Range(.Cells(L, C), _
.Cells(.Cells.Find("*", .[A1], -4123, , _
1, 2).Row, .Cells.Find("*", .[A1], -4123, , _
2, 2).Column))
End With
Exit Function
Fin:
Set DefPlage = Nothing
End FunctionBonjour these
Deja un gros Merci
Je viens de tester et cela fonctionne prfaitement.
Toutefois j'ai un petit probleme cela recupere les valeurs et pas les formules ni les couleurs de base .
Si il n'y as pas d'autre solution je ferais avec.
Merci beaucoup.
Bonjour,
Dans ce cas, il faut copier la feuille afin de la récupérer à l'identique. Seule la Sub "Test" est modifiée donc, je ne re-poste pas les fonctions, par contre, la fonction DefPlage() n'a plus lieu d'être donc, tu peux la supprimer :
Sub Test()
Dim Cls As Workbook
Dim Tbl() As String
Dim Fe As Worksheet
Dim I As Integer
Dim Chemin As String
Dim Nom As String
Dim Message As String
Application.ScreenUpdating = False
'Les fichiers sont dans le même dossier que le classeur contenant cette procédure, à adapter si différent !
Chemin = ThisWorkbook.Path & "\"
'appel de la fonction pour récupérer les noms des classeurs
Tbl = EnumFichiers(Chemin, ".xls*") 'astérisque si tous les fichiers Excel (.xls, .xlsx, .xlsm, etc...)
'si initialisé (au moins 1 classeur)
If Not (Not Tbl) Then
'boucle sur le tableau
For I = 1 To UBound(Tbl)
'évite le classeur contenant la procédure !
If Tbl(I) <> ThisWorkbook.Name Then
'ouvre le classeur
Set Cls = Workbooks.Open(Chemin & Tbl(I))
'récupère le nom du classeurs en cours pour l'atribuer à la feuille
Nom = Left(Cls.Name, InStr(Cls.Name, ".") - 1)
'contrôle si la feuille existe déjà (une erreur est généré si elle n'existe pas)...
On Error Resume Next
Set Fe = ThisWorkbook.Worksheets(Nom)
'...elle n'existe pas, on l'ajoute au classeur...
If Err.Number <> 0 Then
Cls.Worksheets(1).Copy , ThisWorkbook.Worksheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Worksheets(ThisWorkbook.Sheets.Count).Name = Nom
Else
'...elle existe, on construit le message
Message = Message & "La feuille '" & Nom & "' du classeur '" & Cls.Name & "' existe déjà dans ce classeur !" & vbCrLf
End If
Err.Clear
'referme
Cls.Close False
End If
Next I
End If
'affiche le message si au moins une des feuilles qui devaient être copiées existe déjà afin d'attirer l'attention !
If Message <> "" Then MsgBox Message
Application.ScreenUpdating = True
End SubBonjour
Merci beaucoup