XL 2016 Faire une liste sans doublons triee dans une cellule selon une condition

Sub ListeUnique()
  Dim Dico As Object, tblNiveau As Variant, tblReseau As Variant, Ligne As Long
  Dim Tabl As Variant, Txt As String
  Set Dico = CreateObject("Scripting.Dictionary")
  Ligne = 2
  With Sheets("saisie")
    tblNiveau = Application.Transpose(.Range("A3", .Cells(.Rows.Count, 1).End(xlUp)))
    For i = 1 To UBound(tblNiveau)
      If Not Dico.exists(tblNiveau(i)) Then
        Dico.Add tblNiveau(i), tblNiveau(i)
      End If
    Next i
    With Sheets("resultat")
      .[A3:B10000].ClearContents
      For Each Item In Dico.items
        Ligne = Ligne + 1
        .Cells(Ligne, 1) = Item
      Next Item
      Tabl = Application.Transpose(.Range("A3", .Cells(.Rows.Count, 1).End(xlUp)))
    End With
    tblReseau = Application.Transpose(.Range("B3", .Cells(.Rows.Count, 2).End(xlUp)))
    For i = 1 To UBound(Tabl)
      Txt = ""
      Dico.RemoveAll
      For j = 1 To UBound(tblNiveau)
        If tblNiveau(j) = Tabl(i) Then
          If Not Dico.exists(tblReseau(j)) Then
            Dico.Add tblReseau(j), tblReseau(j)
          End If
        End If
      Next j
      If Dico.Count > 0 Then
        For Each Item In Dico.items
          Txt = Txt & Chr(10) & Item
        Next Item
        Txt = Right(Txt, Len(Txt) - 1)
        Ligne = i + 2
        Sheets("resultat").Cells(Ligne, 2) = Txt
      End If
    Next i
  End With
End Sub