Copier coller la feuil1 de 12 classeurs

Y compris Power BI, Power Query et toute autre question en lien avec Excel
Avatar du membre
reinruof77
Membre fidèle
Membre fidèle
Messages : 393
Inscrit le : 10 mars 2014
Version d'Excel : 2010

Message par reinruof77 » 11 octobre 2019, 18:02

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
Je ne suis pas très douer mais j’écoute quand on m'explique ;)
Avatar du membre
reinruof77
Membre fidèle
Membre fidèle
Messages : 393
Inscrit le : 10 mars 2014
Version d'Excel : 2010

Message par reinruof77 » 11 octobre 2019, 20:19

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
Je ne suis pas très douer mais j’écoute quand on m'explique ;)
T
Theze
Passionné d'Excel
Passionné d'Excel
Messages : 4'020
Appréciations reçues : 305
Inscrit le : 26 janvier 2011
Version d'Excel : 2007/2019

Message par Theze » 11 octobre 2019, 20:54

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 Function
Il vaut mieux un qui sait que cent qui cherchent :wink:

Ce forum étant un lieu de partage, je n'accepte pas les messages privés !
Avatar du membre
reinruof77
Membre fidèle
Membre fidèle
Messages : 393
Inscrit le : 10 mars 2014
Version d'Excel : 2010

Message par reinruof77 » 11 octobre 2019, 21:44

Bonjour 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.
Je ne suis pas très douer mais j’écoute quand on m'explique ;)
T
Theze
Passionné d'Excel
Passionné d'Excel
Messages : 4'020
Appréciations reçues : 305
Inscrit le : 26 janvier 2011
Version d'Excel : 2007/2019

Message par Theze » 12 octobre 2019, 09:22

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 Sub
1 membre du forum aime ce message.
Il vaut mieux un qui sait que cent qui cherchent :wink:

Ce forum étant un lieu de partage, je n'accepte pas les messages privés !
Avatar du membre
reinruof77
Membre fidèle
Membre fidèle
Messages : 393
Inscrit le : 10 mars 2014
Version d'Excel : 2010

Message par reinruof77 » 12 octobre 2019, 09:41

Bonjour

Merci beaucoup
Je ne suis pas très douer mais j’écoute quand on m'explique ;)
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message