Public WithEvents QTbl As QueryTable
Private Sub QTbl_BeforeRefresh(Cancel As Boolean)
    Dim arr() As Variant, i&, strSQL$, LO As ListObject
    For Each LO In Sheets("Лист1").ListObjects
        i = i + 1
        ReDim Preserve arr(i)
        arr(i) = LO.Range.Address(0, 0, 1, 1)
    Next
    With Application
        arr = .Substitute(.ReplaceB(arr, 1, Len(ThisWorkbook.Name) + 2, ""), "!", "$")
    End With
    strSQL = "select * from (" & Mid(Join(arr, "] union all select * from ["), 13) & "]) where Сумма"
    QTbl.Connection = "ODBC;DSN=Excel Files;DriverId=1046;DBQ=" & Parent.FullName
    QTbl.CommandText = strSQL
End Sub
Private Sub Worksheet_Activate()
    Init
    QTbl.Refresh
End Sub

Private Sub Workbook_Open()
    Call Init
End Sub

Public tbl As QueryTable
Sub Init()
    If tbl Is Nothing Then Set Лист2.QTbl = Лист2.ListObjects(1).QueryTable
    Set tbl = Лист2.QTbl
End Sub