[Excel][VBA] Recherche de valeurs dans un tab

Sub cousin()
Dim FSource As Worksheet, FDest As Worksheet
Dim Cel As Range
Dim Composant As Object
Dim Tmp
Dim I As Long
Application.ScreenUpdating = False
Set FSource = Sheets("Base")
Set FDest = Sheets("Resultat")
Set Composant = CreateObject("Scripting.Dictionary")
With FSource
    For Each Cel In .Range("C2:C" & .Cells(Rows.Count, 3).End(xlUp).Row)
    Tmp = Split(Cel, ";")
        For I = LBound(Tmp) To UBound(Tmp)
            If Not Composant.Exists(Tmp(I)) Then
                Composant(Tmp(I)) = Cel.Offset(, -2)
            Else
                Composant(Tmp(I)) = Composant(Tmp(I)) & "; " & Cel.Offset(, -2)
            End If
        Next I
    Next Cel
End With
With FDest
    .Range("A2:B5000").Clear
    .Range("A2").Resize(Composant.Count) = Application.Transpose(Composant.Keys)
    .Range("B2").Resize(Composant.Count) = Application.Transpose(Composant.items)
End With
End Sub