Copier sur différentes feuilles en fonction d'un critère

Le 25/02/2019 à 15:52

Bonjour à tous,

J'ai un souci (petit mais quand même), j'ai entré du code VBA dans une feuille excel afin que celle-ci copie une ligne dans une autre feuille (ML) en fonction d'un critère (ici c'est ML également)

Je voudrais que, si il y a le critère "CG", la ligne soit copier dans une autre feuille appelé "CG" également

J'y connais pas grand chose en VBA, donc au début je me suis dit qu'il suffisait de remettre le même code à la suite, mais ça ne marche pas (ça serais trop simple lol)

Ci-dessous le code que j'utilise pour copier vers ML:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim sh, i, DernCol As Integer

Dim Wb_dest As String

Dim Wb_dep As String

Application.ScreenUpdating = False

Wb_dep = ActiveWorkbook.Name

lgn = ActiveCell.Row

Col = ActiveCell.Column

Sheets("ML").Select

Sheets("ML").Range("A4").Select

Sheets("ML").Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

Selection.ClearContents

Sheets("ML").Range("A4").Select

Ligne = 4

For i = 2 To Workbooks(Wb_dep).Sheets(1).Range("A65536").End(xlUp).Row

If Workbooks(Wb_dep).Sheets(1).Range("O" & i) = "ML" Then

Workbooks(Wb_dep).Sheets(1).Range("A" & i & ":O" & i).Copy Workbooks(Wb_dep).Sheets(2).Range("A" & Ligne)

Ligne = Ligne + 1

End If

Next i

' Repositionnement sur la cellule

Sheets("Base").Select

Sheets("Base").Cells(lgn, Col).Select

End Sub

J'ai pas précisé mais je vais avoir d'autres critères pour d'autres feuilles (FS, JM, etc)

Merci d'avance pour votre aide

Le 25/02/2019 à 16:48

Bonjour Arafac, bonjour le forum,

Comme tu ne spécifies rien on ne sait pas de quel onglet tu parles... Le code ci-dessous supprime tout les Select inutiles mais je ne suis pas sûr qu'il convienne...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lng As Integer, Col As Integer, I As Integer, LML As Integer, LGC As Integer
Dim OML As Worksheet, OGC As Worksheet

Application.ScreenUpdating = False
lgn = ActiveCell.Row
Col = ActiveCell.Column
Set OML = Worksheets("ML")
Set OGC = Worksheets("GC")
OML.Range("A4").CurrentRegion.ClearContents
OGC.Range("A4").CurrentRegion.ClearContents
LML = 4
LCG = 4
For I = 2 To Range("A65536").End(xlUp).Row
    If Cells(I, "O").Value = "ML" Then
        Cells(I, "A").Resize(1, 15).Copy OML.Cells(LML, "A")
        LML = LML + 1
    End If
    If Cells(I, "O").Value = "GC" Then
        Cells(I, "A").Resize(1, 15).Copy OGC.Cells(LGC, "A")
        LGC = LGC + 1
    End If
Next I
Application.ScreenUpdating = True
End Sub

Le 25/02/2019 à 17:48

Merci ThauThème pour ta réponse,

Je ne suis pas assez clair je pense donc je met ci-joint l'exemple du fichier que je veux créer.

Avec le critère ML le code VBA fonctionne bien, il me copie bien dans la feuille ML, les lignes entières lorsqu'il y a ML dans commercial affecter sur la feuille "base".

J'aimerais qu'il fasse pareil avec les FS, CG, etc dans les feuilles qui correspond et c'est la ou je commence à sortir les rames lol.

Le 26/02/2019 à 11:48

Re,

Je trouve très mal venu d'utiliser l'événement Change de l'onglet pour ce que tu veux faire. En effet, chaque fois que tu vas modifier une cellule de l'onglet ça va agir... Donc si tu édites une ligne entière (= 25 cellules), la macro se lancera 25 fois. Gros b***el en perspective.

Le code que je te propose peut-être lancé à n'importe quel moment et autant de fois que tu les désires car il commence par supprimer toutes les anciennes données avant de refaire la ventilation des données dans leur onglet respectif. Si l'onglet n'existe pas il le crée...

Voici le code commenté, tu pourras l'associer à un bouton si ça te convient :

Sub Macro1()
Dim OB As Worksheet 'déclare la variable OB (Onglet Base)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim NL As Integer 'déclare la variable NL (Nombre de Lignes)
Dim NC As Integer 'déclare la variable NC (Nombre de Colonnes)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set OB = Worksheets("Base") 'définit l'onglet OB
TV = OB.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
NL = UBound(TV, 1) 'définit le nombre de ligne NL du tableau des valeurs TV
NC = UBound(TV, 2) 'définit le nombre de colonnes NC du tableau des valeurs TV
For Each OD In Worksheets 'boucle sur tous les onglets OD du classeur
    If Not OD.Name = OB.Name Then 'si le nom de l'onglet de la boucle n'est pas le nom de l'onglet OB (=Base)
        OD.Cells.ClearContents 'efface le contenu de l'ongelt OD
        OB.Rows(1).Copy 'copie la ligne 1 de l'ongle OB
        OD.Range("A1").PasteSpecial (xlPasteColumnWidths) 'colle la largeur des colonnes dans l'onglet OD
        OB.Rows(1).Copy OD.Range("A1") 'copie la ligne 1 de l'ongle OB dans la cellule A1 de l'onglet OD
        OD.Activate 'active l'onglet OD
        OD.Range("A1").Select 'sélectionne la cellule A1 de l'onglet OD
    End If 'fin de la condition
Next OD 'prochain onglet de la boucle
For I = 2 To NL 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe a la ligne suivante)
    If TV(I, 14) <> "" Then Set OD = Worksheets(TV(I, 14)) 'définit l'onglet destination si la donnée n'est pas vide (génère une erreur si cet onglet n'existe pas)
    If Err <> 0 Then 'condition : si une erreur a été générée
        Err.Clear 'supprime l'erreur
        Sheets.Add After:=Sheets(Sheets.Count) 'ajoute un onglet vierge en dernière position
        ActiveSheet.Name = TV(I, 14) 'renomme l'onglet
        Set OD = ActiveSheet 'définit l'onglet OD
        OB.Rows(1).Copy 'copy la ligne 1 de l'ongle OB
        OD.Range("A1").PasteSpecial (xlPasteColumnWidths) 'colle la largeur des colonnes dans l'onglet OD
        OB.Rows(1).Copy OD.Range("A1") 'copy la ligne 1 de l'ongle OB dans la cellule A1 de l'onglet OD
    End If 'fin de la condition
    On Error GoTo 0 'annule la gestion des erreurs
    Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST (première cellule vide de la colonne A de l'onglet OD)
    DEST.Resize(1, NC).Value = Application.Index(TV, I) 'renvoie dans DEST redimensionné la ligne I du tableau des valeurs TV
Next I 'prochaine ligne de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

Le 27/02/2019 à 09:52

Bonjour ThauThème,

Merci beaucoup pour tes conseils et pour le code avec les commentaires je suis en train de faire des testes, ça à l'air de bien fonctionner, avec bouton ou directement sur la feuille c'est top merci =D

J'ai juste une petite demande supplémentaire si ça te dérange pas, quand je fait un changement de commercial affectée dans l'onglet "Base", une fois le changement effectuer, à chaque fois il me remet au dernier onglet (PS) en cellule A1.

Est-il possible de rester sur l'onglet "Base" et à la cellule où j'ai effectuer le changement? j'aimerais ne pas bouger en gros, mais que les autres onglets se remplissent sans même y faire attention (ils se remplissent bien mais il me met au dernier onglet à chaque changement).

C'est plus pour du confort, mais aussi car ce tableau ce n'est pas moi qui vais le remplir, mais une collègue.

En tout cas merci beaucoup à toi ThauThème, je te payerais bien un coup à boire pour l'aide que tu m'apportes

Le 27/02/2019 à 14:39

Re,

Code adapté (mais tu aurais pu/dû le faire toi-même !) :

Sub Macro1()
Dim OB As Worksheet 'déclare la variable OB (Onglet Base)
Dim CA As Range 'déclare la variable CA (Cellule Active)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim NL As Integer 'déclare la variable NL (Nombre de Lignes)
Dim NC As Integer 'déclare la variable NC (Nombre de Colonnes)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CA = ActiveCell 'définit la cellule CA
Set OB = Worksheets("Base") 'définit l'onglet OB
TV = OB.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
NL = UBound(TV, 1) 'définit le nombre de ligne NL du tableau des valeurs TV
NC = UBound(TV, 2) 'définit le nombre de colonnes NC du tableau des valeurs TV
For Each OD In Worksheets 'boucle sur tous les onglets OD du classeur
    If Not OD.Name = OB.Name Then 'si le nom de l'onglet de la boucle n'est pas le nom de l'onglet OB (=Base)
        OD.Cells.ClearContents 'efface le contenu de l'ongelt OD
        OB.Rows(1).Copy 'copie la ligne 1 de l'ongle OB
        OD.Range("A1").PasteSpecial (xlPasteColumnWidths) 'colle la largeur des colonnes dans l'onglet OD
        OB.Rows(1).Copy OD.Range("A1") 'copie la ligne 1 de l'ongle OB dans la cellule A1 de l'onglet OD
        OD.Activate 'active l'onglet OD
        OD.Range("A1").Select 'sélectionne la cellule A1 de l'onglet OD
    End If 'fin de la condition
Next OD 'prochain onglet de la boucle
For I = 2 To NL 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe a la ligne suivante)
    If TV(I, 14) <> "" Then Set OD = Worksheets(TV(I, 14)) 'définit l'onglet destination si la donnée n'est pas vide (génère une erreur si cet onglet n'existe pas)
    If Err <> 0 Then 'condition : si une erreur a été générée
        Err.Clear 'supprime l'erreur
        Sheets.Add After:=Sheets(Sheets.Count) 'ajoute un onglet vierge en dernière position
        ActiveSheet.Name = TV(I, 14) 'renomme l'onglet
        Set OD = ActiveSheet 'définit l'onglet OD
        OB.Rows(1).Copy 'copy la ligne 1 de l'ongle OB
        OD.Range("A1").PasteSpecial (xlPasteColumnWidths) 'colle la largeur des colonnes dans l'onglet OD
        OB.Rows(1).Copy OD.Range("A1") 'copy la ligne 1 de l'ongle OB dans la cellule A1 de l'onglet OD
    End If 'fin de la condition
    On Error GoTo 0 'annule la gestion des erreurs
    Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST (première cellule vide de la colonne A de l'onglet OD)
    DEST.Resize(1, NC).Value = Application.Index(TV, I) 'renvoie dans DEST redimensionné la ligne I du tableau des valeurs TV
Next I 'prochaine ligne de la boucle
OB.Activate 'active l'onglet OB
CA.Select 'sélectionne la cellule active CA
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

Le 28/02/2019 à 08:53

Bonjour,

Merci ThauThème pour l'adaptation c'est nickel, c'est exactement se que je rechercher.

C'est vrai que j'aurais pu et même j'aurais du le faire moi même, mais bon quand je vois que j'ai passer 3 jours pour trouver et adapter le code que j'avais a la base (et qui fonctionner que pour 1 critère) et qu'au final avec ton aide j'ai un code totalement différent mais qui fonctionne exactement comme je le souhaite grâce a toi... j'ai beau chercher etc

J'ai vu les 4 lignes que tu as rajoutée, je pense pour cela j'aurais mit encore quelques jours pour trouver, et sans avoir la certitude de ne pas avoir fait une boulette.

Merci en toi cas pour ton aide, je sais pas comment te remercier (nous sommes constructeur de bâtiments industriels si tu as besoin je te ferais un prix )

Le 28/02/2019 à 15:15

Bonjour,

Chef j'ai un souci avec ce code VBA quand je le met dans la feuille j'ai me fait bien met copie sur les autres feuilles en fonction du critère, ça c'est nickel.

Mais lorsque je rajoute une ligne en A2, elle se rajoute bien mais je ne peut pas écrire dans les cellules, ça plante le code. J'ai cette ligne la qui bloque le processus:

Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST (première cellule vide de la colonne A de l'onglet OD)

Car enfaite je créer une ligne à chaque nouveau client, pour avoir les clients les plus récents en haut.

Rechercher des sujets similaires à "copier differentes feuilles fonction critere"