Sub Run_Macro()
Dim strSQL As String

    strSQL = "SELECT [Лист1$].*, [Лист2$].* FROM [Лист1$], [Лист2$];"
    
    GenerateReportSQL (strSQL)

    
MsgBox "йа закончило!"
End Sub 

Private Sub GenerateReportSQL(strSQL As String)
Dim ws As Worksheet
Dim qry As QueryTable
Dim strPath As String
Dim strName As String
Dim strCon As String
'Dim strSQL As String
Dim strPosition As String
Dim strRng As String
Dim tm As Double

    With ThisWorkbook
        On Error Resume Next
        Set ws = .Worksheets("Итог")
        On Error GoTo 0
        If ws Is Nothing Then Set ws = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
        
        strName = .FullName
        strPath = .Path
        strRng = "A2:U"
        strCon = "ODBC;DSN=Excel Files;" & _
                 "DBQ=" & strName & ";" & _
                 "DefaultDir=" & strPath & ";" & _
                 "DriverId=1046;" & _
                 "MaxBufferSize=2048;" & _
                 "Page Timeout=5;"
        
    
        With ws
            If Val(Application.Version) > 11 Then DeleteConnections_12
            .Cells.Clear
            .Name = "Итог"
            Set qry = .QueryTables.Add(strCon, .Range("A1"), strSQL)
            With qry
                .BackgroundQuery = False
                .Refresh
                .Delete
            End With
        End With
        
    End With

End Sub

Private Sub DeleteConnections_12()
' This line won't work and wouldn't be necessary
' in the versions older than 2007
'*****************************************************************************
    On Error Resume Next: ThisWorkbook.Connections(1).Delete: On Error GoTo 0
    '*****************************************************************************
End Sub



 

Sub tt()
    Dim a(), i&
    Dim tm As Single: tm = Timer

    With CreateObject("Scripting.Dictionary"): .comparemode = 1

        a = [ПЕРВАЯ!A1].CurrentRegion.Value
        For i = 2 To UBound(a)
            If a(i, 1) = 15000 Then
                t = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5)
                .Item(t) = .Item(t) + 1
            End If
        Next

        a = [ВТОРАЯ!A1].CurrentRegion.Value
        For i = 2 To UBound(a)
            If a(i, 1) = 15000 Then
                t = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5)
                .Item(t) = .Item(t) + 1
            End If
        Next

        ReDim a(1 To .Count + 1, 1 To 6): i = 1
        a(i, 1) = "ID": a(i, 2) = "NAME": a(i, 3) = "SITY": a(i, 4) = "OLD": a(i, 5) = "УК": a(i, 6) = "ПРОВЕРКА"
        For Each k In .keys
            i = i + 1
            arr = Split(k, "|")
            a(i, 1) = arr(0): a(i, 2) = arr(1): a(i, 3) = arr(2): a(i, 4) = arr(3): a(i, 5) = arr(4)
            a(i, 6) = .Item(k)
        Next

    End With

    Generatesh a

    MsgBox "Запрос выполнен! " & Timer - tm
End Sub


Private Sub Generatesh(arr)
Dim ws As Worksheet
 With ThisWorkbook
        On Error Resume Next
        Set ws = .Worksheets("Итог")
        On Error GoTo 0
        If ws Is Nothing Then Set ws = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
        With ws
            .Cells.Clear
            .Name = "Итог"
            .[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
        End With
    End With
End Sub