XL 2016 images de début/images de fin

Sub Resultat()
Dim d As Object, tablo, n&, i, x$, p%
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = [A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, à adapter
tablo(1, 1) = "1ère image"
tablo(1, 2) = "Dernière image"
n = 1
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    p = InStrRev(x, "_")
    x = Left(x, p)
    If p Then
        If Not d.exists(x) Then
            n = n + 1
            d(x) = n 'mémorise la ligne
            tablo(n, 1) = tablo(i, 1) '1ère image
        End If
        tablo(d(x), 2) = tablo(i, 1) 'dernière image
    End If
Next
'---restitution---
With Sheets("Résultat")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A1] '1ère cellule de restitution, à adapter
        .Resize(n, 2) = tablo
        .Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
    End With
    .Columns.AutoFit 'ajustement largeurs
    With .UsedRange: End With 'actualise la barre de défilement verticale
    .Activate 'facultatif
End With
End Sub

Sub Concatène()
    Application.ScreenUpdating = False
    Range("C:E").ClearContents
    DL = Range("A1000000").End(xlUp).Row
    'En C1 : =STXT(A1;1;NBCAR(A1)-9)
    Range("C1:C" & DL).FormulaR1C1 = "=MID(RC[-2],1,LEN(RC[-2])-9)"
    Range("C1:C" & DL).Value = Range("C1:C" & DL).Value
    ' En D1 : =SI(NB.SI($C$1:C1;C1)=1;A1;"")
    Range("D1:D" & DL).FormulaR1C1 = "=IF(COUNTIF(R1C3:RC[-1],RC[-1])=1,RC[-3],"""")"
    Range("D1:D" & DL).Value = Range("D1:D" & DL).Value
    ' En E1 : =SI(D1<>"";INDEX(A:A;LIGNE()+NB.SI(C:C;C1)-1);"")
    Range("E1:E" & DL).FormulaR1C1 = "=IF(RC[-1]<>"""",INDEX(C[-4],ROW()+COUNTIF(C[-2],RC[-2])-1),"""")"
    Range("E1:E" & DL).Value = Range("E1:E" & DL).Value
    ' Tri
    Columns("D:E").Select
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("D1:D" & DL) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range("D1:E"  & DL)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ' Auto largeur
    Columns("C:C").Delete Shift:=xlToLeft
    Columns("C:E").EntireColumn.AutoFit
    [A1].Select
End Sub