Importer différentes feuil dans un seul classeur

Bonjour A toutes et tous

Je cherche une macro qui permet de copier :

- Plusieurs onglets / feuilles de différents classeurs X vers un seul classeur A

Exemple

Classeur A copier : Feuil 1 / Feuil 2 / Feuil 3 / ….

Classeur X1 (peu contenir plusieurs feuil) : Feuil 1  chemin : C:\....\ Classeur X1

Classeur X2 (peu contenir plusieurs feuil) : Feuil 2  chemin : C:\....\ Classeur X2

Classeur X3 (peu contenir plusieurs feuil) : Feuil 3  chemin : C:\....\ Classeur X3

Classeur X4 (peu contenir plusieurs feuil) : Feuil 4  chemin : C:\....\ Classeur X4

….Est-ce que c’est clair pour vous ou pas ? Si oui, merci d’avance pour votre soutien et vos solutions

Salutations @ vous

Bonjour,

Une piste à adapter :

Sub Test()

    Dim Cls As Workbook
    Dim Tbl() As String
    Dim Chemin As String
    Dim I As Integer

    With Application.FileDialog(4)

        If .Show = -1 Then Chemin = .SelectedItems(1) Else Exit Sub

    End With

    Tbl = Fichiers(Chemin)

    If Not (Not Tbl()) Then

        For I = 1 To UBound(Tbl)

            Set Cls = Workbooks.Open(Tbl(I))

            On Error Resume Next 'évite l'erreur due à la feuille inexistante

            'adapter les noms des feuilles à copier
            Cls.Worksheets(Array("Feuil1", "Feuil2")).Copy ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            Cls.Close False

        Next I

    End If

End Sub

Function Fichiers(Chemin As String) As String()

    Dim TblFichiers() As String
    Dim Fichier As String
    Dim I As Integer

    Fichier = Dir(Chemin & "\*xlsx") 'seulement le fichiers .xlsx (donc sans macro !)

    Do While (Len(Fichier) > 0)

        I = I + 1: ReDim Preserve TblFichiers(1 To I)
        TblFichiers(I) = Chemin & "\" & Fichier
        Fichier = Dir()

    Loop

    Fichiers = TblFichiers()

End Function

Bonjour Theze ,

Je pense qu'il est plus simple pour toi d'avoir un exemple, non ... je viens de tester mais je ne pense pas que c'est ce que je voulais avoir comme résultat ...

Dans le fichier "Test Flotte" je rassemble plusieurs feuil/onglet venant de plusieurs onglet d'autre fichiers ...

Ce que je voulais faire, c'est de mettre à jour :

L'onglet JTN du fichier Test Flotte soit mis à jour depuis l'onglet "actuel" du fichier JTN

L'onglet ASA du fichier Test Flotte soit mis à jour depuis l'onglet "actuel" du fichier ASA

Par la suite et avec une autre macro je rassemble ces onglet dans un seul, comme ici dans l'exemple S14 ...

Opération (mise à jours) à faire tous les jours et plusieurs fois dans la journée ...

Est-ce que c'est plus clair pour toi ? en tt cas j'attends avec impatience ton retour et celui des autres membres du forum ... car là je suis vraiment bloqué ...

Un grand merci pour votre aide les amis

@+++

9jtn.xlsx (10.58 Ko)
8asa.xlsx (10.57 Ko)
13test-flotte.xlsx (111.15 Ko)

Any Help :,( ... j'attends vraiment votre soutien les amis !

Bonjour,

Désolé mais quand je lis ta demande :

Je cherche une macro qui permet de copier :

- Plusieurs onglets / feuilles de différents classeurs X vers un seul classeur A

Exemple

Classeur A copier : Feuil 1 / Feuil 2 / Feuil 3 / ….

Classeur X1 (peu contenir plusieurs feuil) : Feuil 1  chemin : C:\....\ Classeur X1

Classeur X2 (peu contenir plusieurs feuil) : Feuil 2  chemin : C:\....\ Classeur X2

Classeur X3 (peu contenir plusieurs feuil) : Feuil 3  chemin : C:\....\ Classeur X3

Classeur X4 (peu contenir plusieurs feuil) : Feuil 4  chemin : C:\....\ Classeur X4

pour moi, le code que je t'ai donné correspond !

Bon, le code ci-dessous est à mettre dans un module standard du classeur "Test Flotte" et enregistrer en .xlsm. Le code défini la plage sur toute la feuille à partir de A3 (les feuilles "Actuel" des autres classeurs !) et mets les valeurs dans les feuilles correspondantes en ayant au préalable vidé la feuille de ses précédentes valeurs. Si les valeurs des feuilles doivent être conservées, fait le moi savoir :

Sub MiseAJour()

    Dim Cls As Workbook
    Dim Plage As Range

    On Error Resume Next
    Set Cls = Workbooks("ASA.xlsx")

    If Err.Number <> 0 Then MsgBox "Le fichier ASA.xlsx n'est pas ouvert !": Exit Sub

    Set Plage = DefPlage(Cls.Worksheets("Actuel"), 3, 1)

    With ThisWorkbook.Worksheets("ASA")

        .Range(.Cells(3, 1), .Cells(Rows.Count, Plage.Columns.Count)).ClearContents
        .Range(.Cells(3, 1), .Cells(Plage.Rows.Count, Plage.Columns.Count)).Value = Plage.Value

    End With

    Set Cls = Workbooks("JTN.xlsx")

    If Err.Number <> 0 Then MsgBox "Le fichier JTN.xlsx n'est pas ouvert !": Exit Sub

    Set Plage = DefPlage(Cls.Worksheets("Actuel"), 3, 1)

    With ThisWorkbook.Worksheets("JTN")

        .Range(.Cells(3, 1), .Cells(Rows.Count, Plage.Columns.Count)).ClearContents
        .Range(.Cells(3, 1), .Cells(Plage.Rows.Count, Plage.Columns.Count)).Value = Plage.Value

    End With

End Sub

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

Re,

petite précision, les classeurs doivent être ouverts avant le lancement du code sinon, tu auras un message et ça mettra fin à la procédure !

Bonjour Theze,

Il n'y a pas un moyen de faire ouvrir le fichier automatiquement et le fermer une fois la MAj est faite ?

La macro prends uniquement les valeur jusq'à la ligne 13 et pas ce qui est au dessous ?

Merci en tout cas pour ton aide

@+

Re,

petite précision, les classeurs doivent être ouverts avant le lancement du code sinon, tu auras un message et ça mettra fin à la procédure !

Re,

La macro prends uniquement les valeur jusq'à la ligne 13 et pas ce qui est au dessous ?

Oups, désolé, j'ai oublié de prendre en compte le décalage dû aux lignes d'entêtes

Il n'y a pas un moyen de faire ouvrir le fichier automatiquement et le fermer une fois la MAj est faite ?

Donc voici, les fichiers sont sensés être dans le même dossier que le fichier "Test Flotte" :

Sub MiseAJour()

    Dim Cls As Workbook
    Dim Plage As Range

    On Error Resume Next
    Set Cls = Workbooks.Open(ThisWorkbook.Path & "\" & "ASA.xlsx")

    If Err.Number <> 0 Then MsgBox "Erreur lors de l'ouverture !": Exit Sub

    Set Plage = DefPlage(Cls.Worksheets("Actuel"), 3, 1)

    With ThisWorkbook.Worksheets("ASA")

        .Range(.Cells(3, 1), .Cells(Rows.Count, Plage.Columns.Count)).ClearContents
        .Range(.Cells(3, 1), .Cells(Plage.Rows.Count + 2, Plage.Columns.Count)).Value = Plage.Value

    End With

    Cls.Close False

    Set Cls = Workbooks.Open(ThisWorkbook.Path & "\" & "JTN.xlsx")

    If Err.Number <> 0 Then MsgBox "Le fichier JTN.xlsx n'est pas ouvert !": Exit Sub

    Set Plage = DefPlage(Cls.Worksheets("Actuel"), 3, 1)

    With ThisWorkbook.Worksheets("JTN")

        .Range(.Cells(3, 1), .Cells(Rows.Count, Plage.Columns.Count)).ClearContents
        .Range(.Cells(3, 1), .Cells(Plage.Rows.Count + 2, Plage.Columns.Count)).Value = Plage.Value

    End With

    Cls.Close False

End Sub

J'ai un bug disant :

Sub ou fonction non definie !

DefPlage ... non ?

Merci pour ton retour

Re,

La macro prends uniquement les valeur jusq'à la ligne 13 et pas ce qui est au dessous ?

Oups, désolé, j'ai oublié de prendre en compte le décalage dû aux lignes d'entêtes

Il n'y a pas un moyen de faire ouvrir le fichier automatiquement et le fermer une fois la MAj est faite ?

Donc voici, les fichiers sont sensés être dans le même dossier que le fichier "Test Flotte" :

Sub MiseAJour()

    Dim Cls As Workbook
    Dim Plage As Range

    On Error Resume Next
    Set Cls = Workbooks.Open(ThisWorkbook.Path & "\" & "ASA.xlsx")

    If Err.Number <> 0 Then MsgBox "Erreur lors de l'ouverture !": Exit Sub

    Set Plage = DefPlage(Cls.Worksheets("Actuel"), 3, 1)

    With ThisWorkbook.Worksheets("ASA")

        .Range(.Cells(3, 1), .Cells(Rows.Count, Plage.Columns.Count)).ClearContents
        .Range(.Cells(3, 1), .Cells(Plage.Rows.Count + 2, Plage.Columns.Count)).Value = Plage.Value

    End With

    Cls.Close False

    Set Cls = Workbooks.Open(ThisWorkbook.Path & "\" & "JTN.xlsx")

    If Err.Number <> 0 Then MsgBox "Le fichier JTN.xlsx n'est pas ouvert !": Exit Sub

    Set Plage = DefPlage(Cls.Worksheets("Actuel"), 3, 1)

    With ThisWorkbook.Worksheets("JTN")

        .Range(.Cells(3, 1), .Cells(Rows.Count, Plage.Columns.Count)).ClearContents
        .Range(.Cells(3, 1), .Cells(Plage.Rows.Count + 2, Plage.Columns.Count)).Value = Plage.Value

    End With

    Cls.Close False

End Sub

Bonjour,

Tu as supprimé tout le code pour le remplacer par celui-ci-dessus mais il te fallait conserver la fonction DefPlage !

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

Désolé je n'ai pas vraiment compris ... il faut que je rajoute le dernier code ou remplacer le 1 par le derneir

Merci pour ton retour

Bonjour,

Tu as supprimé tout le code pour le remplacer par celui-ci-dessus mais il te fallait conserver la fonction DefPlage !

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

Pour que ce soit plus simple, remplaces tout le code que tu as dans le module par le code ci-dessous :

Sub MiseAJour()

    Dim Cls As Workbook
    Dim Plage As Range

    On Error Resume Next
    Set Cls = Workbooks.Open(ThisWorkbook.Path & "\" & "ASA.xlsx")

    If Err.Number <> 0 Then MsgBox "Erreur lors de l'ouverture !": Exit Sub

    Set Plage = DefPlage(Cls.Worksheets("Actuel"), 3, 1)

    With ThisWorkbook.Worksheets("ASA")

        .Range(.Cells(3, 1), .Cells(Rows.Count, Plage.Columns.Count)).ClearContents
        .Range(.Cells(3, 1), .Cells(Plage.Rows.Count + 2, Plage.Columns.Count)).Value = Plage.Value

    End With

    Cls.Close False

    Set Cls = Workbooks.Open(ThisWorkbook.Path & "\" & "JTN.xlsx")

    If Err.Number <> 0 Then MsgBox "Le fichier JTN.xlsx n'est pas ouvert !": Exit Sub

    Set Plage = DefPlage(Cls.Worksheets("Actuel"), 3, 1)

    With ThisWorkbook.Worksheets("JTN")

        .Range(.Cells(3, 1), .Cells(Rows.Count, Plage.Columns.Count)).ClearContents
        .Range(.Cells(3, 1), .Cells(Plage.Rows.Count + 2, Plage.Columns.Count)).Value = Plage.Value

    End With

    Cls.Close False

End Sub

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

ça ne fonctionne pas ...

toujours le message erreur ... puis fermeture ... déception

Bonjour,

Je viens de re-télécharger tes 3 fichiers, coller mon dernier code et fais le test, tout fonctionne très bien !

toujours le message erreur ... puis fermeture ... déception

Avec une explication comme ça, je ne vais pas pouvoir t'aider ! C'est quoi le message d'erreur ?

Les trois classeurs doivent être dans le même dossier (qu'importe le dossier).

Si tu as modifié quelque chose par rapport aux fichiers postés, il faudrait me le faire savoir !

Ce n'est pas grave ... on considère que la problématique est résolue ...

Est-ce que tu peux m'aider sur un autre sujet, stp ?

ci-joint l'exemple :

En faite je veux copier les colonnes dans le fichier destinataire depuis fichier source quand la valeur de la colonne B de ce dernier est egale à "CLEBAT"

Est-ce claire ?

Merci

Bonjour,

Je viens de re-télécharger tes 3 fichiers, coller mon dernier code et fais le test, tout fonctionne très bien !

toujours le message erreur ... puis fermeture ... déception

Avec une explication comme ça, je ne vais pas pouvoir t'aider ! C'est quoi le message d'erreur ?

Les trois classeurs doivent être dans le même dossier (qu'importe le dossier).

Si tu as modifié quelque chose par rapport aux fichiers postés, il faudrait me le faire savoir !

4destinatair.xlsx (157.26 Ko)
4source.xlsx (314.68 Ko)
Rechercher des sujets similaires à "importer differentes feuil seul classeur"