Microsoft 365 copier valeur selon critères

[Abdoul aziz]

Bonjour à tous j'ai un fichier excel qui est un arbre généalogique c'est à dire niveau 0 = parents (colorié en jaune) ; niveau 1 = enfants(colorié en bleu) ; niveau 2 = petits enfants(colorié en vert) ; niveau 3 = arrière petit enfants(colorié en rouge). jusque là je l'ai rempli de façon manuelle en insérant des lignes
le but c'est de remplir le niveau 4 en partant du niveau 3

Je souhaite une macro qui fait ceci :
il va me chercher la valeur que je souhaite (peut être c'est moi qui va entrer manuellement la valeur dans un user form) dans ma colonne D (il va trouver plusieurs fois cette valeur) . Mais ce que je veux c'est qu'elle me copie tous les ligne de niveaux supérieurs au niveau que je cherche et j'usquà ce que le niveau devient égale au niveau de la valeur de départ

exemple : ma première valeur rechercher sera 10-5195 637 puisque c'est la première valeur du niveau 3
et tout en bas de mon tableau cette valeur revient et donc il doit copier les lignes entourer en bleu et me le coller juste en dessous de ma première valeur 10-5195 637

 

[AtTheOne]

Bonjour à toutes & à tous, bonjour @Abdoul aziz

Le choix se fera par un double clic sur la ligne après laquelle on veut écrire une descendance.

• J'ai transformé ton tableau en tableau structuré nommé "Armoire" (pourquoi pas, il y a un tiroir !)
• J'ai créé 5 formats conditionnels pour les couleurs selon le niveau.
• J'ai géré l'événement BeforeDoubleClick de ta feuille dont voici le code :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
     Dim Réf As String, Niveau As Byte, Nbl As Long, Lgn As Long, NbCopies As Long, TbRes(), Tb, Clefs
     'S'assurer que le clic est dans le tableau
     If Not Intersect(Target, Me.[Armoire]) Is Nothing Then
          'N° P de la ligne cliquée
          Réf = Intersect(Target.EntireRow, Me.[Armoire[N° P]]).Value
          If MsgBox(Prompt:="Créer la descendance de " & Réf, Buttons:=vbYesNo) = vbNo Then Exit Sub
          Cancel = True
          'Niveau hiérarchique de la ligne cliquée
          Niveau = Intersect(Target.EntireRow, Me.[Armoire[Niveau]]).Value
          'Valeurs contenues dans le tableau
          Tb = Me.[Armoire]
          Nbl = UBound(Tb)
          'Clefs pour identifier la descendance
          ReDim Clefs(1 To Nbl)
          For i = 1 To Nbl
               Clefs(i) = Tb(i, 1) & "¤" & Tb(i, 3)
          Next
         'Recherche de la ligne sous laquelle se trouve la descendance
          With WorksheetFunction
               Lgn = -1
               On Error Resume Next
               Lgn = .Match(Niveau - 1 & "¤" & Réf, Clefs, 0)
               On Error GoTo 0
               If Lgn = -1 Then MsgBox "Pas de descendance pour " & Niveau & " - " & Réf: Exit Sub
          End With
          'Comptage des lignes à copier
          NbCopies = 0
          For i = Lgn + 1 To Nbl
               If Tb(i, 1) < Niveau  Then Exit For
               NbCopies = NbCopies + 1
          Next
          If NbCopies > 0 Then
               'Récupération des données (le niveau est augmenté de 1)
               ReDim TbRes(1 To NbCopies, 1 To 4)
               For i = 1 To NbCopies
                    TbRes(i, 1) = Niveau + 1
                    For j = 2 To 4
                         TbRes(i, j) = Tb(Lgn + i, j)
                    Next j
               Next
               'Insérer les cellules
               Intersect(Target.EntireRow, Me.[Armoire]).Offset(1).Resize(NbCopies).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
               'Ecrire les valeurs
               Intersect(Target.EntireRow, Me.[Armoire]).Offset(1).Resize(NbCopies).Value = TbRes
          Else
               MsgBox "Aucune descendance trouvée !"
          End If
     End If

End Sub

Voir le Classeur en pièce jointe
Amicalement
Alain

 

[Abdoul aziz]

Bonjour à toutes & à tous, bonjour @Abdoul aziz

Le choix se fera par un double clic sur la ligne après laquelle on veut écrire une descendance.

• J'ai transformé ton tableau en tableau structuré nommé "Armoire" (pourquoi pas, il y a un tiroir !)
• J'ai créé 5 formats conditionnels pour les couleurs selon le niveau.
• J'ai géré l'événement BeforeDoubleClick de ta feuille dont voici le code :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
     Dim Réf As String, Niveau As Byte, Nbl As Long, Lgn As Long, NbCopies As Long, TbRes(), Tb, Clefs
     'S'assurer que le clic est dans le tableau
     If Not Intersect(Target, Me.[Armoire]) Is Nothing Then
          'N° P de la ligne cliquée
          Réf = Intersect(Target.EntireRow, Me.[Armoire[N° P]]).Value
          If MsgBox(Prompt:="Créer la descendance de " & Réf, Buttons:=vbYesNo) = vbNo Then Exit Sub
          Cancel = True
          'Niveau hiérarchique de la ligne cliquée
          Niveau = Intersect(Target.EntireRow, Me.[Armoire[Niveau]]).Value
          'Valeurs contenues dans le tableau
          Tb = Me.[Armoire]
          Nbl = UBound(Tb)
          'Clefs pour identifier la descendance
          ReDim Clefs(1 To Nbl)
          For i = 1 To Nbl
               Clefs(i) = Tb(i, 1) & "¤" & Tb(i, 3)
          Next
         'Recherche de la ligne sous laquelle se trouve la descendance
          With WorksheetFunction
               Lgn = -1
               On Error Resume Next
               Lgn = .Match(Niveau - 1 & "¤" & Réf, Clefs, 0)
               On Error GoTo 0
               If Lgn = -1 Then MsgBox "Pas de descendance pour " & Niveau & " - " & Réf: Exit Sub
          End With
          'Comptage des lignes à copier
          NbCopies = 0
          For i = Lgn + 1 To Nbl
               If Tb(i, 1) < Niveau  Then Exit For
               NbCopies = NbCopies + 1
          Next
          If NbCopies > 0 Then
               'Récupération des données (le niveau est augmenté de 1)
               ReDim TbRes(1 To NbCopies, 1 To 4)
               For i = 1 To NbCopies
                    TbRes(i, 1) = Niveau + 1
                    For j = 2 To 4
                         TbRes(i, j) = Tb(Lgn + i, j)
                    Next j
               Next
               'Insérer les cellules
               Intersect(Target.EntireRow, Me.[Armoire]).Offset(1).Resize(NbCopies).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
               'Ecrire les valeurs
               Intersect(Target.EntireRow, Me.[Armoire]).Offset(1).Resize(NbCopies).Value = TbRes
          Else
               MsgBox "Aucune descendance trouvée !"
          End If
     End If

End Sub

Voir le Classeur en pièce jointe
Amicalement
Alain

Bonjour Alain merci ton code fonctionne très bien
merci