Do not open any related workbook, otherwise it will be very slow.
Create a new workbook and paste the code and save as .xlsm then run the code from there.
Sub test()
    Dim a, myDir$, fn$, f$, cn$, x(), i&, ii&, n&, myRow
    Const wsName$ = "EXTRACTION"
    myDir = "C:\Users\MMGG\Desktop\SUMMARY DAYS"
    If Dir(myDir, vbDirectory) = "" Then MsgBox "Wrong path", vbCritical, myDir: Exit Sub
    cn = "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=#;Extended Properties='Excel 12.0;HDR=Yes';"
    ReDim a(1 To 50000, 1 To 3)
    fn = Dir(myDir & "\*.xls*")
    Do While fn <> ""
        If Not UCase$(fn) Like "SUMMARY*" Then
            f = "'" & myDir & "\[" & fn & "]" & wsName & "'!"
            If Not IsError(ExecuteExcel4Macro(f & "r1c1")) Then
                myRow = ExecuteExcel4Macro("match(""SUMMARY:""," & f & "c3:c3,0)")
                If Not IsError(myRow) Then
                    With CreateObject("ADODB.Recordset")
                        .Open "Select * From `" & wsName & "$C" & myRow & ":D`;", Replace(cn, "#", myDir & "\" & fn)
                        n = n + 1
                        ReDim Preserve x(1 To 3, 1 To n)
                        x(1, n) = ExecuteExcel4Macro(f & "r7c2")
                        x(2, n) = .GetRows
                        For i = 0 To .Fields.Count - 1
                            x(3, n) = x(3, n) & IIf(x(3, n) <> "", Chr(2), "") & .Fields(i).Name
                        Next
                        x(3, n) = "ITEM" & Chr(2) & x(3, n)
                    End With
                End If
            End If
        End If
        fn = Dir
    Loop
    If n Then ReDim Preserve x(1 To 3, 1 To n): GetDetails x, myDir
End Sub


Sub GetDetails(x, myDir$)
    Dim a, e, i&, ii&, n&, myRows, dic As Object, ref&
    Dim ws As Worksheet, r As Range
    Application.ScreenUpdating = False
    Set ws = ThisWorkbook.Sheets.Add
    ReDim a(1 To UBound(x, 2) * 100, 1 To 3)
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(x, 2)
        n = n + 1: a(n, 2) = "NAME"
        n = n + 1: a(n, 2) = x(1, i)
        n = n + 1
        a(n, 1) = Split(x(3, i), Chr(2))(0): a(n, 2) = Split(x(3, i), Chr(2))(1)
        a(n, 3) = Split(x(3, i), Chr(2))(2): ref = 0
        For ii = 0 To UBound(x(2, i), 2)
            n = n + 1: ref = ref + 1: a(n, 1) = ref
            a(n, 2) = x(2, i)(0, ii): a(n, 3) = x(2, i)(1, ii)
            dic(x(2, i)(0, ii)) = dic(x(2, i)(0, ii)) + x(2, i)(1, ii)
        Next
        n = n + 1
    Next
    ws.[a1].Resize(n, 3) = a
    For Each r In ws.Columns(1).SpecialCells(2).Areas
        With r.CurrentRegion
            With .Cells(1, 2)
                .Font.Bold = True
                .Interior.Color = vbYellow
                .Borders.Weight = 2
            End With
            Union(.Rows(3), .Columns(1)).Font.Bold = True
            .Rows(3).Interior.Color = vbYellow
            .Offset(2).Resize(.Rows.Count - 2).Borders.Weight = 2
        End With
    Next
    With ws.Range("a" & Rows.Count).End(xlUp)(4).Resize(, 3)
        .Range("b1") = "TOTAL NAMES"
        With .Rows(2)
            .Value = Split(x(3, 1), Chr(2))
            .Font.Bold = True
            .Interior.Color = vbYellow
        End With
        With .Rows(3).Resize(dic.Count)
            .Columns(1) = Evaluate("row(1:" & dic.Count & ")")
            .Columns(1).Font.Bold = True
            .Columns("b:c") = Application.Transpose(Array(dic.keys, dic.items))
        End With
        .Rows(2).Resize(dic.Count + 1).Borders.Weight = 2
    End With
    With ws.UsedRange
        .Columns.AutoFit
        .HorizontalAlignment = xlCenter
        .Columns(3).NumberFormatLocal = "#,###.00"
    End With
    ws.Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs myDir & "\SUMMARY RANGES " & Format$(Date, "dd-mm-yyyy"), 51
    ws.Delete
    Application.DisplayAlerts = True
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub