Regrouper lignes avec mêmes données en colonne B et C

[harzer]

Bonjour à tous,
Après plusiuers tentatives, je n’arrive pas à résoudre mon problème, alors je m’adresse à vous pour m’aider.
J’ai une feuille avec 7 colonnes.
Colonne A : N° BAGUE DU JEUNE
Colonne B : N° BAGUE DU PÈRE.
Colonne C : N° BAGUE DE LA MÈRE.
Colonne D : Eleveur
Colonne E : Couleur
Colonne F : Volière
Colonne G : Cage
Vous trouverer en pièce jointe le fichier avec les données.
Etape 1 : Dans la feuille ‘Parents’, je tiens la gestion de mon élevage de canaris avec les origines pour chaque sujet, j’aimerais lors du clic sur une cellule donnée de la colonne A (Colonne des jeunes), on cré une feuille nommée ‘Regrouper Jeunes Du Même Couple’, puis parcourir la feuille ‘Parents’ afin de retrouver tous les jeunes venant du même couple (Père en colonne B, Mère en colonne C).
Etape 2 : Si on clic sur une autre cellule différente de la précedente, on insère une ligne vide puis on insère tous les jeunes venant du même autre couple.
Voici un exemple :
Je clic par exemple sur la clellule de la ligne 61 : HTY27-009/2012 F
HTY27-007/2012 M HTY27-116/2010 M 856-119/2010 F Maes Lucien Entièrement Jaune. 1ere volière Cage 1
HTY27-008/2012 M HTY27-116/2010 M 856-119/2010 F Maes Lucien Entièrement Jaune. 1ere volière Cage 1
HTY27-009/2012 F HTY27-116/2010 M 856-119/2010 F Maes Lucien Entièrement Jaune. 2ème volière Cage 1
HTY27-010/2012 M HTY27-116/2010 M 856-119/2010 F Maes Lucien Entièrement Jaune. 4ème volière Cage 1
HTY27-011/2012 M HTY27-116/2010 M 856-119/2010 F Maes Lucien Entièrement Jaune. 4ème volière Cage 1
On insère une ligne vide.
Je clic par exemple sur la cellule de la ligne 175 : HTY27-095/2012
HTY27-091/2012 M HWA76-020/2011 M HWA72-112/2011 F Maes Lucien Entièrement jaune 2ème volière Cage 16
HTY27-092/2012 M HWA76-020/2011 M HWA72-112/2011 F Maes Lucien Entièrement jaune 1ere volière Cage 16
HTY27-093/2012 M HWA76-020/2011 M HWA72-112/2011 F Maes Lucien Entièrement jaune 2ème volière Cage 16
HTY27-094/2012 M HWA76-020/2011 M HWA72-112/2011 F Maes Lucien Entièrement jaune 2ème volière Cage 16
HTY27-095/2012 M HWA76-020/2011 M HWA72-112/2011 F Maes Lucien Tâche derrière tête 2ème volière Cage 16
Je reste à votre dispisition pour d’autres informations supplémentaires.
D’avance GRAND MERCI de votre aide.

 

[Gurgeh]

Re : Regrouper lignes avec mêmes données en colonne B et C

Salut harzer,

Je vois dans ton fichier que tu as déjà écrit une macro.

Qu'est ce qui ne fonctionne pas exactement ? Ce sera plus facile pour t'aider...

Gurgeh

 

[Robert]

Re : Regrouper lignes avec mêmes données en colonne B et C

Bonjour le fil, bonjour le forum,

Je te propose le code ci-dessous. Dans l'onglet Parents tu double-cliques dans une cellule de la colonne A. Les Jeunes du même couple que la cellule double-cliquée sont regroupés ou un message indique que le jeune est le seul du même couple...
Le code :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim oc As Object 'décalre la variable oc (Onglet Cible)
Dim dl As Integer 'déclare la variable dl (Dernière Ligne)
Dim pl As Range 'déclare la variable pl (PLage)
Dim sl As Range 'déclare la variable sl (Saut de Ligne)
Dim test As Boolean 'déclare la variable test
Dim cel As Range 'déclare la variable cel (CELlule)
Dim dest As Range 'déclare la variable dest (cellule de DESTination)

If Target.Column <> 1 Then Exit Sub 'si le double-clic a lieu ailleurs que dans la colonne 1 (=A), sort de la procédure
If Target.Row = 1 Then Exit Sub 'si le double-clic a lieu dans la ligne 1, sort de la procédure
Cancel = True 'annule le mode édition lié au double-clic
Module1.RegrouperJeunesDuMemeCouple 'lance la procédure "RegrouperJeunesDuMemeCouple" du module "Module1"
Set oc = Sheets("Regrouper Jeunes Du Même Couple") 'définit l'onglet cible
dl = Cells(Application.Rows.Count, 2).End(xlUp).Row 'définit la dernière ligne éditée de la colonne 2 (=B)
Set pl = Range("B2:B" & dl) 'définit la plage pl
If Application.WorksheetFunction.CountIf(pl, Target.Offset(0, 1).Value) = 1 Then 'condition : si le Nº de bague du père n'apparaît qu'une seule fois dans la colonne B
    MsgBox "Un seul jeune du même couple !" 'message
    Exit Sub 'sort de la procédure
Else 'sinon
    'définit la cellule de saut de ligne (A2, si A2 est vide, sinon la seconde cellule vide rencontrée dans la colonne A de l'onglet cible), définit la variable test
    Set sl = IIf(oc.Range("A2").Value = "", oc.Range("A2"), oc.Cells(Application.Rows.Count, 1).End(xlUp).Offset(2, 0)): test = True
    Range("A1").AutoFilter 'applique un filtre automatique en A1
    Range("A1").AutoFilter field:=2, Criteria1:=Target.Offset(0, 1).Value 'filtre la colonne B para rapport au numéro de bague du père (colonne B) de la cellule double-cliquée
    Range("A1").AutoFilter field:=3, Criteria1:=Target.Offset(0, 2).Value 'filtre la colonne C para rapport au numéro de bague de la mère (colonne C) de la cellule double-cliquée
    If pl.SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then 'condition 2 : si il y a plus d'une seule ligne affichée
        'définit la cellule de destination dest (sl si test est vrai, sinon la première ligne vide de la colonne A de l'onglet cible), puis réinitialise la variable test
        Set dest = IIf(test = True, sl, oc.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0)): test = False
        pl.SpecialCells(xlCellTypeVisible).EntireRow.Copy dest 'copie les lignes affichée dans dest
    End If 'fin de la condition 2
End If 'fin de la condition 1
'ActiveSheet.ShowAllData 'affiches toutes les lignes du filtre
If ActiveSheet.AutoFilterMode = True Then Range("A1").AutoFilter 'si il y a un filtre automatique, supprime le filtre automatique
MsgBox "Données traitées !"
End Sub

 

[Robert]

Re : Regrouper lignes avec mêmes données en colonne B et C

Bonjour le fil, bonjour le forum,

Le code légèrement modifié...:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim oc As Object 'décalre la variable oc (Onglet Cible)
Dim dl As Integer 'déclare la variable dl (Dernière Ligne)
Dim pl As Range 'déclare la variable pl (PLage)
Dim sl As Range 'déclare la variable sl (Saut de Ligne)
Dim test As Boolean 'déclare la variable test
Dim cel As Range 'déclare la variable cel (CELlule)
Dim dest As Range 'déclare la variable dest (cellule de DESTination)

If Target.Column <> 1 Then Exit Sub 'si le double-clic a lieu ailleurs que dans la colonne 1 (=A), sort de la procédure
If Target.Row = 1 Then Exit Sub 'si le double-clic a lieu dans la ligne 1, sort de la procédure
Cancel = True 'annule le mode édition lié au double-clic
Module1.RegrouperJeunesDuMemeCouple 'lance la procédure "RegrouperJeunesDuMemeCouple" du module "Module1"

Application.ScreenUpdating = False 'masque les changements à l'écran
Set oc = Sheets("Regrouper Jeunes Du Même Couple") 'définit l'onglet cible
dl = Cells(Application.Rows.Count, 2).End(xlUp).Row 'définit la dernière ligne éditée de la colonne 2 (=B)
Set pl = Range("B2:B" & dl) 'définit la plage pl
If Application.WorksheetFunction.CountIf(pl, Target.Offset(0, 1).Value) = 1 Then 'condition : si le Nº de bague du père n'apparaît qu'une seule fois dans la colonne B
    MsgBox "Un seul jeune du même couple !" 'message
    GoTo fin  'va à l'étiquette fin
Else 'sinon
    'définit la cellule de saut de ligne (A2, si A2 est vide, sinon la seconde cellule vide rencontrée dans la colonne A de l'onglet cible), définit la variable test
    Set sl = IIf(oc.Range("A2").Value = "", oc.Range("A2"), oc.Cells(Application.Rows.Count, 1).End(xlUp).Offset(2, 0)): test = True
    Range("A1").AutoFilter 'applique un filtre automatique en A1
    Range("A1").AutoFilter field:=2, Criteria1:=Target.Offset(0, 1).Value 'filtre la colonne B para rapport au numéro de bague du père (colonne B) de la cellule double-cliquée
    Range("A1").AutoFilter field:=3, Criteria1:=Target.Offset(0, 2).Value 'filtre la colonne C para rapport au numéro de bague de la mère (colonne C) de la cellule double-cliquée
    If pl.SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then 'condition 2 : si il y a plus d'une seule ligne affichée
        'définit la cellule de destination dest (sl si test est vrai, sinon la première ligne vide de la colonne A de l'onglet cible), puis réinitialise la variable test
        Set dest = IIf(test = True, sl, oc.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0)): test = False
        pl.SpecialCells(xlCellTypeVisible).EntireRow.Copy dest 'copie les lignes affichée dans dest
    Else
        MsgBox "Un seul jeune du même couple !" 'message
        GoTo fin  'va à l'étiquette fin
    End If 'fin de la condition 2
End If 'fin de la condition 1
MsgBox "Données traitées !"
oc.Activate 'active l'onglet cible
fin:
If Sheets("Parents").AutoFilterMode = True Then Range("A1").AutoFilter 'si il y a un filtre automatique, supprime le filtre automatique
Application.ScreenUpdating = True 'affiche les changements à l'écran
End Sub

 

[harzer]

Re : Regrouper lignes avec mêmes données en colonne B et C

Bonjour Robert,
Désolé du retard.
D'abord merci pour les solutions, elles répondent toutes les deux à mes attentes.
Bravo et merci encore pour le soutien.
Harzer.

 

[harzer]

Re : Regrouper lignes avec mêmes données en colonne B et C

Bonjour Robert,
Je me permet de te signaler un petit problème, lorsqu'on double clic sur des données déjà traitées, on trouve ces même lignes en double, ce qui est normal d'ailleurs.
Ne serait-il pas judicieux d'ajouter une condition qui nous informe que les données ont déjà été traités et ne pas les dupliquer.
Merci de ton soutien.

 

[Cousinhub]

Re : Regrouper lignes avec mêmes données en colonne B et C

Bonjour,

Il me semble que tu as eu une réponse qui te donnait entièrement satisfaction sur un autre forum.....(et qui te prévenait en cas de doublons....)

Pourquoi demander plus?

@ te relire

 

[harzer]

Re : Regrouper lignes avec mêmes données en colonne B et C

Bonjour bhbh,
Mon fichier, contient plusieurs feuilles, impossible de transférer la totalité (Gros fichier), j'étais obligé de supprimer certaines feuilles pour ne garder que les feuilles concernées.
En effet, j’ai fait les tests avec le code proposé sur la version avec les feuilles réduites.
Lorsque j’ai repris le code pour le mettre dans le projet complet, j’ai des erreurs, impossible de le faire fonctionner.
Voilà l'explication.

 

[Robert]

Re : Regrouper lignes avec mêmes données en colonne B et C

Bonsoir Harzer, bonsoir Bhbh, bonsoir le forum,

Ha ! Si j'avais su ça avant Bhbh, je n'aurais certainement pas agi de la sorte... Je n'aime ni la compétition ni être pris pour un c... !
Mais bon c'est fait alors j'envoie la proposition.
Le code :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'au double-clic dans l'onglet

'*************************
'déclaration des variables
'*************************
Dim oc As Object 'déclare la variable oc (Onglet Cible)
Dim dl As Integer 'déclare la variable dl (Dernière Ligne)
Dim pl As Range 'déclare la variable pl (PLage)
Dim r As Range 'déclare la variable r (Recherche)
Dim sl As Range 'déclare la variable sl (Saut de Ligne)
Dim test As Boolean 'déclare la variable test
Dim cel As Range 'déclare la variable cel (CELlule)
Dim dest As Range 'déclare la variable dest (cellule de DESTination)

'****************************
'zone d'action et préparation
'****************************
If Target.Column <> 1 Then Exit Sub 'si le double-clic a lieu ailleurs que dans la colonne 1 (=A), sort de la procédure
If Target.Row = 1 Then Exit Sub 'si le double-clic a lieu dans la ligne 1, sort de la procédure
Cancel = True 'annule le mode édition lié au double-clic
Module1.RegrouperJeunesDuMemeCouple 'lance la procédure "RegrouperJeunesDuMemeCouple" du module "Module1"
Set oc = Sheets("Regrouper Jeunes Du Même Couple") 'définit l'onglet cible
dl = Cells(Application.Rows.Count, 2).End(xlUp).Row 'définit la dernière ligne éditée de la colonne 2 (=B)
Set pl = Range("B2:B" & dl) 'définit la plage pl

'**********************
'traitement des données
'**********************
Application.ScreenUpdating = False 'masque les changements à l'écran
'condition 1 : si le Nº de bague du père n'apparaît qu'une seule fois dans la colonne B
If Application.WorksheetFunction.CountIf(pl, Target.Offset(0, 1).Value) = 1 Then
    MsgBox "Un seul jeune du même couple !" 'message
    GoTo fin  'va à l'étiquette fin
Else 'sinon (condition 1)

    '*********************
    'données déjà traitées
    '*********************
    'définit la recherche r (recherche la valeur de la cellule double-cliquée dans la colonne 1 (=A) de l'onglet odt
    Set r = oc.Columns(1).Find(Target.Value, , xlValues, xlWhole)
    If Not r Is Nothing Then 'condition 2: si il existe au moins une occurrence trouvée
        'condition 3 : si oui au message
        If MsgBox("Jeune déjà regroupé ! Voulez-vous voir les données regroupées ?", vbYesNo) = vbYes Then
            oc.Select: r.Select 'sélectionne la donnée traitée
            Exit Sub 'sort de la procédure
        Else 'sinon (condition 3)
            GoTo fin 'va à l'étiquette "fin"
        End If 'fin de la condition 3
    End If 'fin de la condition 2
    
    '***********************************
    'filtre des données et copier/coller
    '***********************************
    'définit la cellule de saut de ligne (A2, si A2 est vide, sinon la seconde cellule vide rencontrée dans la colonne A de
    'l'onglet cible), définit la variable test
    Set sl = IIf(oc.Range("A2").Value = "", oc.Range("A2"), oc.Cells(Application.Rows.Count, 1).End(xlUp).Offset(2, 0)): test = True
    Range("A1").AutoFilter 'applique un filtre automatique en A1
    'filtre la colonne B para rapport au numéro de bague du père (colonne B) de la cellule double-cliquée
    Range("A1").AutoFilter field:=2, Criteria1:=Target.Offset(0, 1).Value
    'filtre la colonne C para rapport au numéro de bague de la mère (colonne C) de la cellule double-cliquée
    Range("A1").AutoFilter field:=3, Criteria1:=Target.Offset(0, 2).Value
    If pl.SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then 'condition 4 : si il y a plus d'une seule ligne affichée
        'définit la cellule de destination dest (sl si test est vrai, sinon la première ligne vide de la colonne A de
        'l'onglet cible), puis réinitialise la variable test
        Set dest = IIf(test = True, sl, oc.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0)): test = False
        pl.SpecialCells(xlCellTypeVisible).EntireRow.Copy dest 'copie les lignes affichée dans dest
    Else 'sinon (condition 4)
        MsgBox "Un seul jeune du même couple !" 'message
        GoTo fin  'va à l'étiquette fin
    End If 'fin de la condition 4
End If 'fin de la condition 1

'*****************************
'fin de traitement des données
'*****************************
MsgBox "Données traitées !" 'message
oc.Activate 'active l'onglet cible

'**********************
'suppresion des filtres
'**********************
fin: 'étiquette
If Sheets("Parents").AutoFilterMode = True Then Range("A1").AutoFilter 'si il y a un filtre automatique, supprime le filtre automatique
Application.ScreenUpdating = True 'affiche les changements à l'écran
End Sub

Le fichier :

 

[Cousinhub]

Re : Regrouper lignes avec mêmes données en colonne B et C

Re-,

Salut Robert

Ici, je lui avais fourni ce code....

qui, en son temps, faisait le boulot....

Maintenant, si son fichier exemple n'est pas conforme à son fichier réel, ça va pas être simple, surtout s'il ne peut pas adapter les codes proposés

Bonne soirée

 

[Robert]

Re : Regrouper lignes avec mêmes données en colonne B et C

Bonsoir le fil, bonsoir le forum,

Bhbh j'ai flashé sur ton code beaucoup plus conci que le mien mais il a un défaut, il envoie quand même les données s'il y n'y a qu'un seul jeune issu du même couple. Je me suis permis de corriger (mais comme je maîtrise pas les filtres avancés c'est un peu tiré par les cheveux...)
Le code :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim r As Range
Dim DerLig As Long
Dim nl As Integer

Application.ScreenUpdating = False 'masque les changements à l'écran
If Not Intersect(Columns(1), Target) Is Nothing And Target.Row > 1 And Target <> "" Then
    Cancel = True
    'définit la recherche r (recherche la valeur de la cellule double-cliquée dans la colonne 1 (=A) de l'onglet odt
    Set r = Sheets("Resultat").Columns(1).Find(Target.Value, , xlValues, xlWhole)
    If Not r Is Nothing Then 'condition 2: si il existe au moins une occurrence trouvée
        'condition 3 : si oui au message
        If MsgBox("Jeune déjà regroupé ! Voulez-vous voir les données regroupées ?", vbYesNo) = vbYes Then
            Sheets("Resultat").Select: r.Select 'sélectionne la donnée traitée
            Exit Sub 'sort de la procédure
        End If 'fin de la condition 3
    End If 'fin de la condition 2
    With Sheets("Resultat")
        .Range("A1:G1").Value = Me.Range("A1:G1").Value
        DerLig = IIf(IsEmpty(.Range("A2")), 1, .Cells(Rows.Count, 1).End(xlUp).Row)
    End With
    With Sheets("Parents")
        .Range("A1:G" & .Cells(Rows.Count, 1).End(xlUp).Row).Name = "base"
        .Range("M1:N1").Value = .Range("B1:C1").Value
        .Range("M2:N2").Value = Target.Offset(, 1).Resize(1, 2).Value
        .Range("base").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=.Range("M1:N2")
        nl = Application.Intersect(.Columns(1), Range("base").SpecialCells(xlCellTypeVisible)).Cells.Count
        If nl < 3 Then
            MsgBox "Un seul jeune issu des mêmes parents"
            .ShowAllData
            Exit Sub
        End If
        .ShowAllData
        .Range("base").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("M1:N2"), _
            CopyToRange:=Sheets("Resultat").Cells(DerLig + 1, 1)
        .Range("M1:N2").Clear
    End With
    With Sheets("Resultat")
        If DerLig = 1 Then
            .Rows(DerLig + 1).Delete
        Else
            .Rows(DerLig + 1).Clear
        End If
    End With
End If
If MsgBox("Données traitées! Voulez-vous voir les données regroupées ?", vbYesNo) = vbYes Then
    With Sheets("Resultat")
        .Select
        .Cells(Application.Rows.Count, 1).End(xlUp).Select
        ActiveCell.End(xlUp).Select
    End With
End If 'fin de la condition 3
Application.ScreenUpdating = True 'affiche les changements à l'écran
End Sub

Pour Harzer :
Le nom des onglets change selon tes exemples ici c'est Resultat. Pense à adapter le code en fonction...
Le fichier :

 

[harzer]

Re : Regrouper lignes avec mêmes données en colonne B et C

Bonjour Robert, bonjour Bhbh, bonjour le forum,
Cette fois ci, j’ai pris le temps pour faire mes testes dans des conditions réelles (c.-à-d. dans mon grand fichier), le code me donne entièrement satisfaction ainsi que les résultats souhaités, Grand MERCI à Robert et à Bhbh pour votre aide appréciable.
Cordiale poignée de mains à vous deux et plaisir de vous lire.