Base de données evolutive

Sub Extraction_BD()
Dim Plage As Range, Mondico As Object, i&, j&, k&, Nb&, tabl2
Application.ScreenUpdating = False
Set Plage = Sheets("Feuil1").[A1].CurrentRegion
Set Mondico = CreateObject("scripting.dictionary")
j = 0
For i = 1 To Plage.Rows.Count
    Mondico(Plage(i, 1) & Plage(i, 2) & Plage(i, 3)) = Plage(i, 1) & Plage(i, 2) & Plage(i, 3)
    Dim tabl()
    ReDim Preserve tabl(Plage.Rows.Count, Plage.Columns.Count - 1)
    tabl(j, 0) = Plage(i, 1)
    tabl(j, 1) = Plage(i, 2)
    tabl(j, 2) = Plage(i, 3)
    j = j + 1
Next i
With Sheets("Feuil2")
    .Activate
    .[A1].CurrentRegion.Clear
    Nb = Application.WorksheetFunction.Max(Plage.Columns(4))
    .[A1].Resize(Mondico.Count, Plage.Columns.Count) = tabl
    
        For i = 1 To Mondico.Count
        k = 1
            For j = 1 To Plage.Rows.Count
                If Plage(j, 1) = tabl(i - 1, 0) And Plage(j, 2) _
                = tabl(i - 1, 1) And Plage(j, 3) = tabl(i - 1, 2) Then
                    .Cells(i, 3 + k) = Plage(j, 4): k = k + 1: If k > Nb Then Exit For
                End If
            Next j
        Next i
    .Range(.Cells(1, 4), .Cells(1, 4 + Nb - 1)).Merge
    .Range(.Cells(1, 4), .Cells(1, 4 + Nb - 1)).HorizontalAlignment = xlCenter
    .Cells(1, 4).Value = "Evolution"
    .Range(.Cells(2, 4), .Cells(Mondico.Count, 4 + Nb - 1)).Activate
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
    .[A1].Select
    End With
    Application.ScreenUpdating = True
End Sub