Groupe de cellules nommées, inclus dans un plus grand groupe

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim nom As Names
Dim i As Integer
Set nom = ActiveWorkbook.Names
For i = 1 To nom.Count
    Set isect = Intersect(Target, Range(nom(i)))
    If Not (isect Is Nothing) Then
        If isect.Address = Target.Address Then
        Set trouvé = nom(i)
        MsgBox trouvé.Name
        End If
    End If
Next
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Cells.Count = 1 Then 'Vérification qu'une seule cellule a été sélectionnée

    Set RngWrk = Range("I:K")  'Réserver trois colonnes pour la zone de travail (Peuvent être masquées)
    RngWrk.ClearContents
    i = 1

    ' Recherche de tous les ranges incluant la zone sélectionnée
    For Each Nam In ActiveWorkbook.Names
        If Not Intersect(Selection.Cells(1), Nam.RefersToRange) Is Nothing Then
            RngWrk.Cells(i, 1) = Nam.Name
            RngWrk.Cells(i, 2) = Nam.RefersToRange.Cells.Count
            RngWrk.Cells(i, 3) = Nam.RefersToRange.Cells(1, Nam.RefersToRange.Columns.Count).Value
            i = i + 1
        End If
        Next Nam
    
    ' Tri des Ranges sur nombre de cellules pour reconstituer la hiérarchie de regoupement
    RngWrk.Sort Key1:=RngWrk.Cells(2), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
  
    ' Préparation et affichage du message résultat
    Msg = "Vous avez sélectionné :" & Chr(13)
    i = 1
    While RngWrk.Cells(i, 1) <> ""
        Msg = Msg & RngWrk.Cells(i, 3) & Chr(13)
        i = i + 1
        Wend
    
    If i > 1 Then MsgBox Msg
    RngWrk.ClearContents
    
 End If
 
End Sub