XL 2010 Récupération Cellule

Private Sub Worksheet_Activate()
Dim d As Object, i&, v, col&, n&, resu$(), a, s1, s2, j%, k%
'---tableau des résultats---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
With Sheets("Base").[A1].CurrentRegion
    For i = 2 To .Rows.Count
        v = .Cells(i, 1).Value
        If d.exists(v) Then
            col = d(v)
            resu(1, col) = resu(1, col) & vbLf & .Cells(i, 2)
            resu(2, col) = resu(2, col) & " " & Len(.Cells(i, 2))
            resu(3, col) = resu(3, col) & " " & .Cells(i, 2).Font.Color
        Else
            n = n + 1
            d(v) = n 'mémorise la colonne
            ReDim Preserve resu(1 To 3, 1 To n)
            resu(1, n) = .Cells(i, 2)
            resu(2, n) = Len(.Cells(i, 2))
            resu(3, n) = .Cells(i, 2).Font.Color
        End If
    Next i
End With
If n Then a = d.keys
'---restitution---
Application.ScreenUpdating = False
With [A2] '1ère cellule de destination, à adapter
    .Cells(1, 2).Resize(Rows.Count - .Row + 1).Font.ColorIndex = xlAutomatic
    For i = 1 To n
        .Cells(i, 1) = a(i - 1)
        .Cells(i, 2) = resu(1, i)
        s1 = Split(resu(2, i)) 'longueur
        s2 = Split(resu(3, i)) 'couleur
        k = 1
        For j = 0 To UBound(s1)
            .Cells(i, 2).Characters(k, s1(j)).Font.Color = s2(j)
            k = k + s1(j) + 1
    Next j, i
    If n Then .Resize(n).EntireRow.AutoFit 'ajustement hauteurs
    .Offset(n).Resize(Rows.Count - n - .Row + 1).EntireRow.Delete 'RAZ en dessous
End With
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub