Ayé, j'ai trouvé. La nuit porte conseil. Il n'y a qu'à adapter !
Sub arborescence()
Dim nomA As String
Dim NomB As String
Dim ligneA As Integer
Dim ligneB As Integer
Dim ligneC As Integer
ligneC = "3"
Dim test As Integer
For ligneA = 3 To 1000
test = "0"
If Not IsEmpty(Cells(ligneA, 1)) Then
nomA = Cells(ligneA, 1)
For ligneB = 3 To 1000
If Not IsEmpty(Cells(ligneB, 2)) And Cells(ligneB, 2) = nomA Then
test = test + 1
End If
Next ligneB
If test = 0 Then
Cells(ligneC, 6) = nomA
ligneC = ligneC + 1
End If
End If
Next ligneA
' phase deux = niveau 2
For ligneA = 3 To 1000
If Not IsEmpty(Cells(ligneA, 6)) Then
nomA = Cells(ligneA, 6)
For ligneB = 3 To 1000
If Not IsEmpty(Cells(ligneB, 1)) And Cells(ligneB, 1) = nomA Then
Cells(ligneA, 5) = Cells(ligneB, 2)
End If
Next ligneB
End If
Next ligneA
' suppression doublons phase 2
For ligneA = 3 To 1000
If Not IsEmpty(Cells(ligneA, 5)) Then
nomA = Cells(ligneA, 5)
For ligneB = ligneA + 1 To 1000
If Not IsEmpty(Cells(ligneB, 5)) And Cells(ligneB, 5) = nomA Then
Cells(ligneB, 5) = ""
End If
Next ligneB
End If
Next ligneA
' phase 3 = niveau 1
For ligneA = 3 To 1000
If Not IsEmpty(Cells(ligneA, 5)) Then
nomA = Cells(ligneA, 5)
For ligneB = 3 To 1000
If Not IsEmpty(Cells(ligneB, 1)) And Cells(ligneB, 1) = nomA Then
Cells(ligneA, 4) = Cells(ligneB, 2)
End If
Next ligneB
End If
Next ligneA
' suppression doublons phase 3
For ligneA = 3 To 1000
If Not IsEmpty(Cells(ligneA, 4)) Then
nomA = Cells(ligneA, 4)
For ligneB = ligneA + 1 To 1000
If Not IsEmpty(Cells(ligneB, 4)) And Cells(ligneB, 4) = nomA Then
Cells(ligneB, 4) = ""
End If
Next ligneB
End If
Next ligneA
End Sub