Recherche et copie dans une autre ligne

Sub essais()

    
Dim Dico As New Dictionary
Dim x As Integer
Dim i As Integer
Application.ScreenUpdating = False
 
With Sheets("Qtité Famille")
 
For x = 6 To Range("A" & Rows.Count).End(xlUp).Row 'De la ligne 6 a la dernière avec des données
    For i = 5 To 10 'De la colonne E à la colonne J
        If Not Dico.Exists(.Cells(x, 1).Value) And .Cells(x, i) = True Then  'Si la cellule est vrai et que ca n'existe pas dans le dico
        Dico.Add .Cells(x, 1).Value, .Cells(5, i).Value 'récupère les valeurs
        'Dico.Item(.Cells(x, 1).Value) = Dico.Item(.Cells(x, 1).Value)
        ElseIf Dico.Exists(.Cells(x, 1).Value) And .Cells(x, i) = True Then 'si la cellule est vrai et que ca existe déjà dans le dico
         Dico.Item(.Cells(x, 1).Value) = Dico.Item(.Cells(x, 1).Value) & " / " & .Cells(5, i).Value 'récupère les anciennes et nouvelles correspondances
        End If
        
    Next i 'colonne suivante
Next x 'ligne suivante
 
For x = 6 To Range("X" & Rows.Count).End(xlUp).Row 'De la ligne 6 a la dernière avec des données
    On Error Resume Next 'si erreur ligne suivante
    .Range("AE" & x).Value = Dico(.Range("X" & x).Value) 'Donne les correspondances
Next x 'ligne suivante
 
End With
Application.ScreenUpdating = True
 
End Sub