Option Explicit
Option Private Module
'====================================================================================================
Sub CollectExcel()
Dim dS As New Dictionary, dD As New Dictionary, arrFile() As String, arrAll()
Dim x, arr, tx$, strContr$, s#, t!, f&, r&, rr&, nR&, c&, nC&, colStore&, colDate&, colVal&, p&, AC&, fRow As Boolean, fCol As Boolean

'tx = ActiveWorkbook.Path: If Not FolderChoose(tx) Then Exit Sub
t = Timer: tx = "D:\РАБОТА\Справка\Сборник\Research\VBA vs Python\Папка с файлами"
If Not GetPaths(tx, arrFile) Then Exit Sub
strContr = "transaction_date": ReDim arrAll(1 To 1000000, 1 To 100)
nR = 1: nC = 1: colStore = 2: colDate = 3: colVal = 6

Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.EnableEvents = False
AC = Application.Calculation: Application.Calculation = xlCalculationManual

    For f = 1 To UBound(arrFile, 1)
        Workbooks.Open Filename:=arrFile(f), UpdateLinks:=False, ReadOnly:=True
        arr = ActiveSheet.UsedRange.Value2: ActiveWorkbook.Close False

        If arr(1, 3) = strContr Then p = 0: GoTo cyc
        If arr(1, 4) = strContr Then p = 1: GoTo cyc
        Err.Raise xlErrNA
cyc:
        For rr = 2 To UBound(arr, 1)
            If dS.Exists(arr(rr, colStore)) Then    ' город/магазин
                fCol = True:    c = dS(arr(rr, colStore))
            Else
                fCol = False:   c = nC + 1:         nC = c: arrAll(1, nC) = arr(rr, colStore):                      dS.Add arr(rr, colStore), nC
            End If
    
            x = arr(rr, colDate + p)
            If dD.Exists(x) Then            ' дата
                fRow = True:    r = dD(x)
            Else
                fRow = False:   r = nR + 1:         nR = r: arrAll(nR, 1) = DateSerial(Year(x), Month(x) + 1, 0):   dD.Add x, nR
            End If
    
            If fCol And fRow Then arrAll(r, c) = arrAll(r, c) + arr(rr, colVal + p) Else arrAll(r, c) = arr(rr, colVal + p)
        Next rr
    Next f

f = nC: nC = nC + 1: arrAll(1, nC) = "TOTAL"
    For r = 2 To nR
        For c = 2 To f
            s = s + arrAll(r, c)
        Next c
        arrAll(r, nC) = s: s = 0
    Next r

Cells(1, 1).Resize(nR, nC).Value2 = arrAll
Application.DisplayAlerts = True: Application.EnableEvents = True: Application.Calculation = AC: Application.ScreenUpdating = True
MsgBox "Files have been processed: " & Format$(UBound(arrFile, 1), "#,##0") & vbLf & "Rows download: " & Format$(nR, "#,##0"), vbInformation, Format$(Timer - t, "0.00 sec")
End Sub
'====================================================================================================
'====================================================================================================
Private Function FolderChoose(ByRef tmpDefPath) As Boolean
Dim PS$

PS = Application.PathSeparator
If Not Right$(tmpDefPath, 1) = PS Then tmpDefPath = tmpDefPath & PS

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Choose the FOLDER"
        .ButtonName = "Folder choose"
        .Filters.Clear
        .InitialFileName = tmpDefPath
        .InitialView = msoFileDialogViewDetails
        If .Show = 0 Then Exit Function
        PS = .SelectedItems(1)
        If Len(PS) < 4 Then MsgBox "Can't search in Drive!" & vbLf & "Please, choose the FOLDER!", vbCritical, "FolderChoose": Exit Function
        tmpDefPath = PS
    End With

FolderChoose = True
End Function
'====================================================================================================
Private Function GetPaths(FolderPath$, arrStr() As String) As Boolean
Dim FSO As New FileSystemObject, n&
    ReDim arrStr(1 To 100000)
    RecurSearch FSO, arrStr, n, FolderPath
    If n = 0 Then Exit Function
    ReDim Preserve arrStr(1 To n)
    GetPaths = True
End Function
'----------------------------------------------------------------------------------------------------
Private Sub RecurSearch(FSO As FileSystemObject, arrS() As String, n&, FP$)
Dim curFol, iFile, sFol, tx$

Set curFol = FSO.GetFolder(FP)
    If curFol.Files.Count Then
        For Each iFile In curFol.Files
            tx = iFile.Path
            If Not tx Like "*~*" And tx Like "*.xls*" Then n = n + 1: arrS(n) = tx
        Next iFile
    End If

    For Each sFol In curFol.SubFolders
        RecurSearch FSO, arrS, n, sFol.Path
    Next sFol

Set iFile = Nothing: Set curFol = Nothing
End Sub
'====================================================================================================