appliquer filtre sur fichier unique, puis copier coller le résultat

Y compris Power BI, Power Query et toute autre question en lien avec Excel
g
gperros
Jeune membre
Jeune membre
Messages : 30
Inscrit le : 6 octobre 2014
Version d'Excel : 2007

Message par gperros » 15 février 2019, 13:35

Bonjour à tous,

J'ai lu plusieurs sujets qui traite du même sujet et utilisé l'enregistreur de MACRO, mais mon cas est toujours différent, et je n'arrive pas à l'adapter.

Voilà mon cas:
Je dispose d'une part d'un fichier qui me sert de "base de données"(BDD). Ce fichier contient plusieurs onglets par année.
Je dispose d'autre part de 500 fichiers "projet" (1 fichier par projet, avec un format unique), également constitués de plusieurs onglets par année.

L'objectif est de copier le code du "projet1" (en cellule B2 de chaque onglet), de le coller dans le filtre fu fichier "BDD" pour obtenir un filtre sur le "projet 1".
La plage de donnée filtrée dans la BDD doit ensuite être copié collé dans le "projet1".
Cette action est à répéter pour chaque onglet "2018" / "2019" et pour chaque projet (Projet1/Projet2....Projet500).

J'ai mis à disposition des fichiers simplifiées. J'espère que cela aider à la compréhension.

Merci d'avance pour votre aide.
Projet1.xlsx
(12.35 Kio) Téléchargé 13 fois
BDD.xlsx
(14.61 Kio) Téléchargé 13 fois
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 14'029
Appréciations reçues : 830
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR
Téléchargements : Mes applications

Message par Steelson » 15 février 2019, 18:00

Bonjour

Sujet intéressant
Puisque personne ne prend, je vais me faire violence et adapter un code que j'ai pour un seul onglet ... rendez-vous demain si j'y arrive !

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
g
gperros
Jeune membre
Jeune membre
Messages : 30
Inscrit le : 6 octobre 2014
Version d'Excel : 2007

Message par gperros » 15 février 2019, 18:15

Oui au final si un code fonctionne pour un onglet, ça marchera pour les autres vu qu'ils sont facilement identifiables.
J'avais testé des Macros, mais je ne pense pas que le résultat puisse t'être utile vu que j'utilisais l'enregistreur de macro (et que ça ne fonctionnais pas).

Merci pour ton implication!
T
Theze
Passionné d'Excel
Passionné d'Excel
Messages : 4'019
Appréciations reçues : 306
Inscrit le : 26 janvier 2011
Version d'Excel : 2007/2019

Message par Theze » 15 février 2019, 18:27

Bonjour,

Pour voir si le résultat convient, tu ouvres tes deux classeurs exemple et tu colles le code ci-dessous dans un module standard du classeur "BDD.xlsx" puis tu exécutes (curseur dans le code puis appui sur F5). Si le résultat te convient, on peut aller plus loin avec boucle sur les classeurs et sur les feuilles :
Sub Filtre()
    
    Dim ClBDD As Workbook
    Dim ClProjet As Workbook
    Dim Plage As Range
    Dim Cel As Range
    Dim Critere As String
    
    Set ClBDD = Workbooks("BDD.xlsx")
    Set ClProjet = Workbooks("Projet1.xlsx")
    
    Critere = ClProjet.Worksheets("2018").Range("B2").Value
    
    Set Plage = DefPlage(ClBDD.Worksheets("2018"))
    
    Plage.AutoFilter 2, "=" & Critere
    ClBDD.Worksheets("2018").AutoFilter.Range.EntireRow.Copy ClProjet.Worksheets("2018").Range("A1")
    
    Plage.AutoFilter
    
End Sub
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 !
g
gperros
Jeune membre
Jeune membre
Messages : 30
Inscrit le : 6 octobre 2014
Version d'Excel : 2007

Message par gperros » 15 février 2019, 20:16

J'ai fait un test mais il y a un message d'erreur de compilation (sub ou function non définie) à ce niveau du code:
Set Plage = DefPlage(ClBDD.Worksheets("2018"))

Par contre j'ai un doute avec cette partie du code:
Set ClProjet = Workbooks("Projet1.xlsx")
Cela signifie que je vais devoir renommer "projet1" a chaque fois? lorsque je ferai la manip sur le fichier "projet2".......?

Merci
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 14'029
Appréciations reçues : 830
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR
Téléchargements : Mes applications

Message par Steelson » 16 février 2019, 01:42

Bonjour Theze,

Comme promis
Option Explicit
Sub fragmenter()
Dim i%, j%, Origine As Workbook
Dim dico As Object, tbl As Variant, cle As Variant
Dim xl As Excel.Application, Cible As Workbook

    Set Origine = ThisWorkbook
    Set dico = CreateObject("Scripting.Dictionary")
    For i = 1 To Origine.Worksheets.Count
        With Origine.Sheets(i).ListObjects(1)
                If .ShowAutoFilter Then .AutoFilter.ShowAllData
                tbl = .ListColumns(2).DataBodyRange
                For j = 1 To UBound(tbl)
                    dico(tbl(j, 1)) = dico(tbl(j, 1)) + 1
                Next
        End With
    Next
    Set xl = CreateObject("Excel.Application")
    xl.SheetsInNewWorkbook = Origine.Worksheets.Count
    xl.Visible = True
    For Each cle In dico.Keys
        Set Cible = xl.Workbooks.Add
        For i = 1 To Origine.Worksheets.Count
            With Origine.Sheets(i).ListObjects(1)
                .Range.AutoFilter Field:=2, Criteria1:=cle
                .Range.Copy
                With Cible.Sheets(i)
                    .Select
                    .Paste
                    .Name = Origine.Sheets(i).Name
                    .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes).Name = "T_" & Origine.Sheets(i).Name
                    .ListObjects(1).TableStyle = "TableStyleMedium2"
                End With
                .AutoFilter.ShowAllData
            End With
        Next
        Cible.SaveAs (Origine.Path & "\" & cle & ".xlsx")
    Next
    xl.SheetsInNewWorkbook = 1
    xl.Quit
    Application.CutCopyMode = False

End Sub
fragmenter plusieurs onglets en plusieurs fichiers.xlsm
(24.94 Kio) Téléchargé 17 fois

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
T
Theze
Passionné d'Excel
Passionné d'Excel
Messages : 4'019
Appréciations reçues : 306
Inscrit le : 26 janvier 2011
Version d'Excel : 2007/2019

Message par Theze » 16 février 2019, 07:45

Bonjour,

Oups :oops: j'ai oublié la fonction :
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 !
g
gperros
Jeune membre
Jeune membre
Messages : 30
Inscrit le : 6 octobre 2014
Version d'Excel : 2007

Message par gperros » 18 février 2019, 09:39

Salut Theze,

J'ai testé ta solution mais je ne dois pas positionner le complément au bon endroit car j'ai droit au message d'erreur "end sub attendu".
Pourtant je l'ai bien mis à la fin...

Sub Filtre()

Dim ClBDD As Workbook
Dim ClProjet As Workbook
Dim Plage As Range
Dim Cel As Range
Dim Critere As String


Set ClBDD = Workbooks("BDD.xlsx")
Set ClProjet = Workbooks("Projet1.xlsx")

Critere = ClProjet.Worksheets("2018").Range("B2").Value

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


Set Plage = DefPlage(ClBDD.Worksheets("2018"))

Plage.AutoFilter 2, "=" & Critere
ClBDD.Worksheets("2018").AutoFilter.Range.EntireRow.Copy ClProjet.Worksheets("2018").Range("A1")

Plage.AutoFilter

End Sub

J'ai essayé en enlevant "function" et "and function", mais pas mieux :oops:
g
gperros
Jeune membre
Jeune membre
Messages : 30
Inscrit le : 6 octobre 2014
Version d'Excel : 2007

Message par gperros » 18 février 2019, 09:47

Salut Steelson,

Ta formule est hyper intéressante, mais le "souci", c'est qu'elle créée les fichiers "projet1" "projet2"...
Alors que dans mon cas, les fichiers "projet" sont déjà existants, et seuls les onglets "2018" et "2019" sont à mettre à jour.
Je ne sais pas si ça a son importance, mais je vais devoir ouvrir chaque fichier "projet" pour leur mise à jour car je dois vérifier certaines données. Donc ça signifie que le fichier BDD et le fichier "projet..." seront ouvert lors de la mise à jour. Je pense que ça peut avoir un impact pour le code (si on inscrit le code module VBA du fichier "BDD", l'autre fichier excel "projet" peut-être considéré comme "active.sheet").

Tu vois ce que je veux dire?
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 14'029
Appréciations reçues : 830
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR
Téléchargements : Mes applications

Message par Steelson » 18 février 2019, 11:10

Bonjour,

est-ce que dans les fichiers projetsXXX les années 2018 et 2019 existent déjà ?

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message