Copier automatiquement selon critère vers une autre feuille

Bonjour,

Je souhaiterai faire une copie automatique des données saisies sur une feuille vers d'autres feuilles dans le même classeur.

La copie se fera selon le critère "type" représenté dans la colonne 2 de notre tableau. Le critère type est issu d'une liste de validation et chaque type représente une feuille.

Lorsqu'on saisi des lignes dans la feuille 1 ou se trouve notre tableau, les données doivent se reprodruire dans la feuille correspondant au champ type.

J'arrive à le faire avec un filtre avancé en fonction du critère recherché, mais je voudrais qu'il se fasse automatiquement sans actions dans les feuilles nommés type.

Pouvez vois m'aider s'il existe un ensemble de formule.

Cordialement

Bonjour Xmas et

Dans thisworkbook :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Left(Sh.Name, 4) = "Type" Then
        Sheets(1).Cells(Rows.Count, 1).End(xlUp).CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sh.Range("B1").CurrentRegion, CopyToRange:=Sh.Range("A4").CurrentRegion.Resize(1), Unique:=False
    End If
End Sub

avec quelques aménagements ...

Hello Steelson,

Merci pour l'accueil et la reponse rapide c'est gentil.

Je vois que tu as ajouté une macro mais je ne sais pas trop laquelle. Pourrais tu m'expliquer les amenagements dans les feuilles Type.

En B2 des feuilles, j'y ai mis le nom de l'onglet

=SUBSTITUE(DROITE(CELLULE("nomfichier";B1);NBCAR(CELLULE("nomfichier";B1))-TROUVE("]";CELLULE("nomfichier";B1)));"_";"")

en fait cette formule suffit :

=DROITE(CELLULE("nomfichier";B1);NBCAR(CELLULE("nomfichier";B1))-TROUVE("]";CELLULE("nomfichier";B1)))

B1:B2 de vient donc le critère du filtre avancé

et j'ai décalé les résultats à partir de la ligne 4

La macro est à mettre ici :

Hello Steelson,

J'espère que tu vas bien ? pour la première partie c'est okay, mais je ne pige pas encore la macro. Si tu pouvais m'expliquer se serait bien car j'ai une erreur sur le tableau de la feuille 1.

En faisant debug j'ai

Cordialement

Steelson a écrit :

En B2 des feuilles, j'y ai mis le nom de l'onglet

=SUBSTITUE(DROITE(CELLULE("nomfichier";B1);NBCAR(CELLULE("nomfichier";B1))-TROUVE("]";CELLULE("nomfichier";B1)));"_";"")

en fait cette formule suffit :

=DROITE(CELLULE("nomfichier";B1);NBCAR(CELLULE("nomfichier";B1))-TROUVE("]";CELLULE("nomfichier";B1)))

B1:B2 de vient donc le critère du filtre avancé

et j'ai décalé les résultats à partir de la ligne 4

La macro est à mettre ici :

Capture d’écran (499).png

Est-ce que tu as une erreur sur le fichier que je t'ai posté ?

Pour la macro ...

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Left(Sh.Name, 4) = "Type" Then
        Sheets(1).Cells(Rows.Count, 1).End(xlUp).CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sh.Range("B1").CurrentRegion, CopyToRange:=Sh.Range("A4").CurrentRegion.Resize(1), Unique:=False
    End If
End Sub

• 1- Je prends les feuilles dont le nom commence par Type
  
  Attention ... si tu es en cours de mise en place, la macro va s'activer alors que tu n'as pas encore positionné les données ! Dans ce cas mets provisoirement un autre nom comme _Type 1 de façon à bloquer la macro

• 2- Le filtre prend comme données
  
  c'est une façon assez universelle de les identifier
  mais cela veut dire :
  la première feuille du classeur

• rien en dessous des données car Cells(Rows.Count, 1).End(xlup) signifie que l'on remonte depuis la fin ultime de la feuille colonne 1, et qu'on prend la "région"

• données collées en colonne 1

• 3- Les critères sont en B1:B2 ici (Range("B1").CurrentRegion), dans B1 il y a le titre de la colonne avec la même orthographe, strictement

• 4- Les résultat se situe sur la ligne 4 (CopyToRange:=Sh.Range("A4").CurrentRegion.Resize(1))

Les 2, 3 et 4 peuvent aussi s'écrire de façon plus adaptée à ton sujet. Exemple :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Left(Sh.Name, 4) = "Type" Then
        Sheets("Sheet1").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sh.Range("B1:B2"), CopyToRange:=Sh.Range("A4:H4"), Unique:=False
    End If
End Sub

ou mieux

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Left(Sh.Name, 4) = "Type" Then
        Sheets("Sheet1").Range("Table1[#All]").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sh.Range("B1:B2"), CopyToRange:=Sh.Range("A4:H4"), Unique:=False
    End If
End Sub

Merci pour ta reponse, oui j'ai une erreur. Je te renvoie le fichier.

Tu as une ligne vierge en ligne 25, il ne trouve donc pas les données source car il ne peut pas "englober toute la région", il y a rupture !

Sheets(1).Cells(Rows.Count, 1).End(xlUp).CurrentRegion

Tu peux prendre la dernière formule que je t'ai donnée...

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Left(Sh.Name, 4) = "Type" Then
        Sheets("Sheet1").Range("Table1[#All]").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sh.Range("B1:B2"), CopyToRange:=Sh.Range("A4:H4"), Unique:=False
    End If
End Sub

C'est maintenant plus claire, je vais m'amuser à changer la position du critère de tel sorte que les resultats du filtre ne soient pas décalés sur la ligne 4.

En effet, tu peux les mettre sur les colonnes 1, laisser la colonne 2 vierge, et masquer ensuite ces colonnes

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Not Left(Sh.Name, 4) = "Type" Then Exit Sub
    Sheets("Sheet1").Range("Table1[#All]").AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Sh.Range("A1:A2"), CopyToRange:=Sh.Range("C1:J1"), Unique:=False
End Sub

Hello Steelson,

Encore merci pour le soutien, en principe mon post est resolu (l'idée première).

Cependant, je continue de le personnaliser un peu plus. La macro s'applique sur le classeur en particulier les feuilles actives commençant par type. Dans le cas ou les feuilles ne portent pas toutes le nom "type" et portent d'autres noms comme "Espace", "couloir", etc. Dois je appliquer la macro à chaque feuille concernée?

Merci pour tes orientations

Tu changes juste cette ligne

If Not Left(Sh.Name, 4) = "Type" Then Exit Sub

exemple :

If Not Sh.Name Like "Type*" And Not Sh.Name Like "Couloir*" Then Exit Sub

etc.

Hello Steelson,

Super interessant la modif ça m'a donné des idées pour faire un peu plus compliqué.

Maintenant je voudrais creer un sous type avec des caractères complétement differents.Ensuite mettre la selection du filtre sur une feuille et utilliser ma liste deroulante pour automatiquement creer le filtre associé à la même macro.