Microsoft 365 Définir le rattachement hiérarchique

let
A = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
B = Table.ColumnNames(A),
C = List.TransformMany(Table.ToRows(A), each {_{2}} &
    Table.ToColumns(Table.SelectRows(A, (x)=> Record.Field(x, B{0}) = _{1})){2}, (x,y)=> {x{0},y}),
D = Table.FromRows(C, {B{0}, B{2}})
in D

let
A = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
B = {List.Combine, List.Transform, Record.FieldOrDefault, Table.Column},
C = Table.ColumnNames(A),
D = (x)=> B{1}(x, Text.Trim),
E = (x)=> List.RemoveItems(x, {""}),
F = ((x)=> Record.FromList(x{1}, D(x{0}))) (Table.ToColumns(Table.Group(A, C{0}, {"x", each D(B{3}(_,C{2}))}))),
G = Table.AddColumn(Table.FromColumns({B{3}(A,C{0})}, {C{0}}), C{2}, each E(List.Skip(B{0}(List.Generate(
    ()=> D({B{2}(_, C{0})}), each E(_) <> {}, each B{0}(B{1}(_, (x)=> B{2}(F,x, {""})))))))),
H = Table.Distinct(Table.ExpandListColumn(G, C{2}))
in H

Dim resu(), tablo, n&, manag 'mémorise les variables

Sub Liste()
Dim i&
ReDim resu(1 To Rows.Count, 1 To 2)
tablo = [A2].CurrentRegion.Resize(, 3) 'matrice, plus rapide
n = 0
For i = 3 To UBound(tablo)
    n = n + 1
    manag = tablo(i, 1)
    resu(n, 1) = manag
    resu(n, 2) = tablo(i, 3)
    Recursive tablo(i, 2)
Next i
'---restitution---
With [E4]
    If n Then
        .Resize(n, 2) = resu
        .Resize(n, 2).Sort .Cells, xlAscending, .Columns(2), , xlAscending, Header:=xlNo 'tri sur 2 colonnes
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
    .CurrentRegion.Columns.AutoFit 'ajustement largeurs
End With
End Sub

Sub Recursive(colab)
Dim i&
For i = 3 To UBound(tablo)
    If tablo(i, 1) = colab Then
        n = n + 1
        resu(n, 1) = manag
        resu(n, 2) = tablo(i, 3)
        Recursive tablo(i, 2)
    End If
Next i
End Sub

Dim tablo, resu(), d As Object, manag 'mémorise les variables

Sub Liste()
Dim i&, n&, nn&, s
tablo = [A2].CurrentRegion.Resize(, 3) 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 2)
Set d = CreateObject("Scripting.Dictionary")
For i = 3 To UBound(tablo)
    manag = tablo(i, 1)
    If d.exists(manag) Then
        n = d(manag)
        resu(n, 2) = resu(n, 2) & Chr(1) & tablo(i, 3)
    Else
        nn = nn + 1
        d(manag) = nn 'mémorise la ligne
        resu(nn, 1) = manag
        resu(nn, 2) = tablo(i, 3)
    End If
    Recursive tablo(i, 2)
Next i
'---restitution---
Application.ScreenUpdating = False
With [E4]
    If nn Then
        .Resize(nn, 2) = resu
        .Resize(nn, 2).Sort .Cells, xlAscending, Header:=xlNo 'tri sur 1 colonne
        For i = 1 To nn
            s = Split(.Cells(i, 2), Chr(1))
            tri s, 0, UBound(s)
            .Cells(i, 2) = Join(s, ", ") 'séparateur modifiable
        Next i
    End If
    .Offset(nn).Resize(Rows.Count - nn - .Row + 1, 2).ClearContents 'RAZ en dessous
    .CurrentRegion.Columns.AutoFit 'ajustement largeurs
End With
End Sub

Sub Recursive(colab)
Dim n&, i&
n = d(manag)
For i = 3 To UBound(tablo)
    If tablo(i, 1) = colab Then
        resu(n, 2) = resu(n, 2) & Chr(1) & tablo(i, 3)
        Recursive tablo(i, 2)
    End If
Next i
End Sub

Sub tri(a, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub

Dim tablo, resu(), d As Object, manag 'mémorise les variables

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i&, n&, nn&, s
tablo = [Tableau1].Resize(, 3) 'tableau structuré, matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 2)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tablo)
    manag = tablo(i, 1)
    If d.exists(manag) Then
        n = d(manag)
        resu(n, 2) = resu(n, 2) & Chr(1) & tablo(i, 3)
    Else
        nn = nn + 1
        d(manag) = nn 'mémorise la ligne
        resu(nn, 1) = manag
        resu(nn, 2) = tablo(i, 3)
    End If
    Recursive tablo(i, 2)
Next i
'---restitution---
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
With [Tableau2] 'tableau structuré
    If Not .ListObject.DataBodyRange Is Nothing Then .Delete xlUp 'RAZ
    If nn Then
        .Resize(nn, 2) = resu
        .Resize(nn, 2).Sort .Cells, xlAscending, Header:=xlYes 'tri sur 1 colonne
        For i = 1 To nn
            s = Split(.Cells(i, 2), Chr(1))
            If UBound(s) > 0 Then tri s, 0, UBound(s)
            .Cells(i, 2) = Join(s, ", ") 'séparateur modifiable
        Next i
    End If
    .EntireColumn.AutoFit 'ajustement largeurs
End With
Application.EnableEvents = True 'réactive les évènements
End Sub

Sub Recursive(colab)
Dim n&, i&
n = d(manag)
For i = 1 To UBound(tablo)
    If colab <> "" And tablo(i, 1) = colab Then
        resu(n, 2) = resu(n, 2) & Chr(1) & tablo(i, 3)
        Recursive tablo(i, 2)
    End If
Next i
End Sub

Sub tri(a, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub

Option Explicit
Sub test()
    Dim Rng As Range, HtmlDoc As Object, lId, lID2, i&, e, MaN, Collab, CentreCout, elem
    Set Rng = Range("A3:c" & Cells(Rows.Count, 1).End(xlUp).Row)
    Set HtmlDoc = CreateObject("htmlfile")
    'creation de la hiérarchie HTML
    HtmlDoc.body.innerhtml = "<body></body>"
    For i = 2 To Rng.Rows.Count
        
        'colonne MANAGER
        lId = UCase(Replace(Rng.Cells(i, 1), " ", "_"))
        Set e = HtmlDoc.getelementbyid(lId)
        If e Is Nothing Then
            Set MaN = HtmlDoc.body.appendchild(HtmlDoc.createelement("p"))
            MaN.setattribute "id", lId
            MaN.setattribute "class", UCase(Replace(Rng.Cells(1, 1), " ", "_"))
             Else
            Set MaN = e
            MaN.setattribute "class", UCase(Replace(Rng.Cells(1, 1), " ", "_")) & " " & UCase(Replace(Rng.Cells(1, 2), " ", "_"))
        End If
        'colonne centre de cout
        Set CentreCout = HtmlDoc.createelement("a")
        CentreCout.innerhtml = Rng.Cells(i, 3)
        CentreCout.setattribute "class", "cout"
        MaN.appendchild CentreCout
        
        'colonne collaborateur
        lID2 = UCase(Replace(Rng.Cells(i, 2), " ", "_"))
        Set e = HtmlDoc.getelementbyid(lID2)
        If e Is Nothing Then
            Set Collab = HtmlDoc.createelement("p")
            Collab.setattribute "id", lID2
            Collab.setattribute "class", UCase(Rng.Cells(1, 2))
            MaN.appendchild Collab
        Else
            Set Collab = e
        End If
        
    Next
    'voir le html obtenu
    Debug.Print HtmlDoc.body.innerhtml
    
    'taratata
    'a partir d'ici on pourrait construire un tableau  avec les donnée comme je le fait avec texte
        Dim texte$
    For Each elem In HtmlDoc.all
        If elem.getattribute("class") Like "*MANAGER*" Then
            For Each e In elem.getelementsbytagname("A")
                texte = texte & elem.ID & "-" & e.innertext & vbCrLf
              
            Next
        End If
    Next
    MsgBox texte
End Sub

Dim Rng As Range, HtmlDoc As Object, lId, lID2, i&, e as object, MaN, Collab, CentreCout, elem