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

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.

13bdd.xlsx (14.61 Ko)
13projet1.xlsx (12.35 Ko)

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 !

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!

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

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

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

Bonjour,

Oups 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

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

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?

Bonjour,

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

Oui, ils existent, mais les données ne sont pas à jour.

Est-ce qu'il faut écraser complètement m'onglet avec les nouvelles données ? y a t'il des données ajoutées à préserver dans ces onglets ?

Il y a des formules à conserver à la droite de l'extraction (de la colonne X à AC).

Le problème est que tu fichier projet1 n'était donc pas représentatif ... en aurais-tu un représentatif de la réalité.

Car j'ai encore des questions ...

  • les données sont-elles déjà bien sous forme de tableau ?
  • les nouvelles données sont-elles à ajouter ? ou bien il faut comparer les fichiers et n'ajouter que les nouvelles lignes ? ou bien faut-il mettre jour les lignes déjà existantes et ajouter de nouvelles ?

Ok du coup je t'envoies en pièce jointe un vrai exemple et quelques explications:

  • onglet synthèse: c'est l'onglet de présentation, là où les informations sont misent en forment (les infos sont piochées dans les autres onglets). Cet onglet est figé, je ne le modifie pas.
  • onglet "identité projet": il me sert juste à obtenir une image des infos dans l'onglet synthèse (je peux grâce à cela, masquer des colonnes sans masquer ces informations).
  • onglet "frais de pers": pas encore fonctionnel
  • onglet "BI 2017": il s'agit d'une extraction du budget 2017. J'ai colorié en vert les données qui ne bougent pas (de A1 à U1, il s'agit de l'entête qui conserve toujours le même format, et de V... à AC..., il s'agit de formules (ici c'est un copié collé valeur pour alléger le fichier, mais dans BI 2018 les formules sont bien là). En bleu ce sont les données à mettre à jour. Il faut donc écraser ces données anciennes avec de nouvelles issues du fichier "BDD"
  • onglet BI 2018: Idem
  • onglet "CJIA 2018": même code couleur: en vert ne pas toucher, et en bleu, écraser avec de nouvelles données. les nouvelles données conserve le même nombre de colonne. Seul le nombre de ligne change.

J'espère avoir répondu à tes interrogations

PS: le code P204-0004_VRPOM est le code du projet (il est unique, 1 code par projet).

Opus, la pièce jointe n'était pas à jour. la voici avec les bonnes couleurs.

Il faut que je reprenne tout le code, et on s'écarte beaucoup du standard. Cela risque de me prendre quelques temps ...

Bonjour à vous deux,

Sinon je ne sais pas si la proposition de Theze pouvait fonctionner car je n'ai pas réussi à correctement placer son complément de code suivant:

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

Guillaume

Bonjour Guillaume,

je ne peux pas répondre pour Theze ... je n'ai pas encore réussi à dégager du temps mais cela vient ...

Bonjour,

Le code complet est :

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

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

mais je l'ai conçu par rapport aux deux fichiers que tu as posté à l'ouverture seulement, je vois que les fichiers n'ont aucun rapport avec celui montré en dernier !

Steelson a travaillé pour rien sur ton projet car maintenant, il ne correspond pratiquement (ou même absolument) en rien à l'origine et c'est pour cette raison que je dis toujours que les fichiers postés en exemple doivent impérativement ressembler le plus possible au fichier original (copie de ce ou ces derniers avec anonymisation des données). Je vais un peu me pencher sur ton fichier mais comme je n'ai pas pris la peine de lire votre échange, ça va pas être pour tout de suite.

Rechercher des sujets similaires à "appliquer filtre fichier unique puis copier coller resultat"