Résume de données de tableau(récapitulatif)

Option Explicit
Sub test()
Dim a(), myAreas As Areas, i As Long, n As Long
    Application.ScreenUpdating = False
    On Error Resume Next
    Set myAreas = Sheets(1).Columns(5).SpecialCells(2, 2).Areas
    On Error GoTo 0
    If myAreas Is Nothing Then Exit Sub
    ReDim a(1 To myAreas.Count - 1, 1 To 4)
    For i = 2 To myAreas.Count
        n = n + 1
        a(n, 1) = myAreas(i).Offset(myAreas(i).Rows.Count, -4).Resize(1, 1).Value
        a(n, 2) = Application.Sum(myAreas(i).Offset(, 2))
        a(n, 3) = Application.Sum(myAreas(i).Offset(, 4))
        If a(n, 2) > 0 Then a(n, 4) = a(n, 3) / a(n, 2)
    Next
    With Sheets(1).Range("p3").Resize(, 4)
        .CurrentRegion.Clear
        .Value = [{"Nom inspecteur","Interventions totales","Totale intervention vérifiées","Pourcentage"}]
        .Offset(1).Resize(n).Value = a
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .BorderAround Weight:=xlThin
                .HorizontalAlignment = xlCenter
                .Interior.ColorIndex = 36
                .Font.Size = 11
            End With
            .Columns(4).NumberFormat = "0.00%"
            .Columns.AutoFit
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Option Explicit
Sub nettoyage()
'nettoyage préalable de la Feuil1
Dim derCol As Long, i As Long
    Application.ScreenUpdating = False
    With Sheets("Feuil1")
        .UsedRange.UnMerge
        derCol = Cells(3, Columns.Count).End(xlToLeft).Column
        For i = derCol To 1 Step -1
            If Application.WorksheetFunction.CountA(.Columns(i)) = 0 Then
                .Columns(i).Delete
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub

Sub test()
Dim a(), myAreas As Areas, i As Long, n As Long
    Application.ScreenUpdating = False
    On Error Resume Next
    Set myAreas = Sheets("Feuil1").Columns(2).SpecialCells(2, 2).Areas
    On Error GoTo 0
    If myAreas Is Nothing Then Exit Sub
    ReDim a(1 To myAreas.Count, 1 To 4)
    n = 1
    a(n, 1) = "Nom inspecteur": a(n, 2) = "Interventions totales"
    a(n, 3) = "Totale intervention vérifiées": a(n, 4) = "Pourcentage"
    For i = 2 To myAreas.Count
        n = n + 1
        a(n, 1) = myAreas(i).Offset(myAreas(i).Rows.Count, -1).Resize(1).Value
        a(n, 2) = Application.Sum(myAreas(i).Offset(, 2))
        a(n, 3) = Application.Sum(myAreas(i).Offset(, 3))
        If a(n, 2) > 0 Then a(n, 4) = a(n, 3) / a(n, 2)
    Next
    With Sheets("Feuil1").Cells(3, 1).End(xlToRight).Offset(, 3)
        .CurrentRegion.Clear
        With .Resize(n, 4)
            .Value = a
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .BorderAround Weight:=xlThin
                .HorizontalAlignment = xlCenter
                .Interior.ColorIndex = 22
            End With
            .Columns(4).NumberFormat = "0.00%"
            .Columns.AutoFit
        End With
    End With
    Application.ScreenUpdating = True
End Sub