Supprimer caractères à gauche de cellules et comptabiliser la catégorie

Sub Prénoms()
Dim T$, Tablo(), d As Object
Dim i%, j%, k%, x%
Set d = CreateObject("Scripting.Dictionary")
With Feuil1
    For i = 8 To .Cells(.Rows.Count, 1).End(xlUp).Row
        If .Cells(i, 1) Like "Prénom*" Then
            T = Split(.Cells(i, 1), " ")(1)
            If Not d.exists(T) Then
                d.Add T, T
                x = x + 1
                ReDim Preserve Tablo(1 To 2, 1 To x)
                Tablo(1, x) = T
                Tablo(2, x) = Application.SumIf(.Columns(1), "*" & T, .Columns(2))
            End If
        End If
    Next
    For i = 1 To UBound(Tablo, 2)
        j = i
        For k = j + 1 To UBound(Tablo)
            If Tablo(1, k) <= Tablo(1, j) Then j = k
        Next
        If i <> j Then
            sT1 = Tablo(1, j)
            sT2 = Tablo(2, j)
            Tablo(1, j) = Tablo(1, i)
            Tablo(2, j) = Tablo(2, i)
            Tablo(1, i) = sT1
            Tablo(2, i) = sT2
        End If
    Next
End With
With Feuil3
    .Range("A2").Resize(UBound(Tablo, 2), UBound(Tablo, 1)) = Application.Transpose(Tablo)
End With
End Sub

Sub Calc()
Dim T$, Tablo(), d As Object
Dim n%, id, i%, j%, k%, x%, lh%, lf%
Set d = CreateObject("Scripting.Dictionary")
n% = Cells(Rows.Count, 9).End(xlUp).Row
Range("H26:I" & n%).Select 'nettoie la zone de réception des calculs
VID
id = Sheets(15).Range("H23").Value 'détermine le type d'identifiant à centraliser

With Feuil15 'calcul de Kjin 19janv13 [url]www.excel-downloads.com/forum/199532[/url]
    For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
        'If .Cells(i, 1) Like "Prénom*" Then
        If .Cells(i, 3) Like id Then
            T = Split(.Cells(i, 3), " ")(1)
            If Not d.exists(T) Then
                d.Add T, T
                x = x + 1
                ReDim Preserve Tablo(1 To 2, 1 To x)
                Tablo(1, x) = T
                Tablo(2, x) = Application.SumIf(.Columns(1), "*" & T, .Columns(2))
            End If
        End If
    Next
    For i = 1 To UBound(Tablo, 2)
        j = i
        For k = j + 1 To UBound(Tablo)
            If Tablo(1, k) <= Tablo(1, j) Then j = k
        Next
        If i <> j Then
            sT1 = Tablo(1, j)
            sT2 = Tablo(2, j)
            Tablo(1, j) = Tablo(1, i)
            Tablo(2, j) = Tablo(2, i)
            Tablo(1, i) = sT1
            Tablo(2, i) = sT2
        End If
    Next
End With
With Feuil15
    .Range("H26").Resize(UBound(Tablo, 2), UBound(Tablo, 1)) = Application.Transpose(Tablo)
lh = .Cells(Rows.Count, 8).End(xlUp).Row
    Range("H26:I" & lh).Select 'ordonner
    Selection.Sort Key1:=Range("H26"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

lf = lh + 2
.Range("H" & lf).Value = "TOTAL :"
.Range("I" & lf).Value = "=SUM(I26:I" & lh & ")"
.Range("I26:I" & lf).NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
.Range("I26:I" & lf).Font.Bold = True
Range("H26:I" & lh).Select 'cadrer
cadre
'Range("H" & lf & ":I" & lf).Select
'cadre
Range("H23").Select
End With
End Sub