Sub StajInExcel (код As Double)
On Error GoTo Err_StajInExcel
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim objPivotCache As Excel.PivotCache
    Dim MyRange As Excel.Range
    Dim rs As New ADODB.Recordset

    rs.CursorLocation = adUseClient 'Рекордсет будет создан у клиента
    rs.Open "SELECT First(Таблица.Дата) AS Дата, First(Таблица.Время) AS Время, Sum(Таблица.X1) AS X, Таблица.Номер1 AS [Номер] " & _
            "FROM Таблица GROUP BY Таблица.Номер1, Таблица.Код, Таблица.Дата, Таблица.Время, Таблица.Номер1 HAVING (((First(Таблица.Код))=" & код & ") AND " & _
            "((Count(Таблица.Код))>1) AND ((Count(Таблица.Время))>1));", _
        CurrentProject.Connection, adOpenStatic, adLockReadOnly, adCmdText

    Set xlApp = CreateObject("Excel.Application") 'Создание объекта MSExcel
    Set xlBook = xlApp.Workbooks.Add 'Создание файла Excel
    'xlApp.Visible = True 'Выводим на экран (оставлено для возможной отладки)
    xlApp.DisplayAlerts = False 'Запрет возможных сообщений MSExcel

    Set xlSheet = xlBook.Sheets(1)
    With xlSheet
        .Name = "Сводная" 'Присваивем листу имя
        'Создаем сводную таблицу с внешним источником данных (xlExternal)
        Set objPivotCache = xlBook.PivotCaches.Add(xlExternal)
        'Присваиваем сводной таблице в качестве источника данных рекордсет (rs)
        Set objPivotCache.Recordset = rs
        rs.Close 'Закрываем рекордсет, т.к. он больше не нужен
        Set rs = Nothing 'Чистим память от объекта

        'Создаем каркас для сводной и указываем что будет строками, а что столбцами
        .PivotTables.Add PivotCache:=objPivotCache, TableDestination:=.Cells(2, 1), TableName:="Svodnaya"
        With .PivotTables("Svodnaya").PivotFields("Дата")
            .Orientation = xlRowField 'Строка
            .Position = 1 'Позиция №1
        End With
        With .PivotTables("Svodnaya").PivotFields("Время")
            .Orientation = xlRowField 'Строка
            .Position = 2 'Позиция №2
        End With
        With .PivotTables("Svodnaya").PivotFields("Номер")
            .Orientation = xlColumnField 'Столбец
            .Position = 1 'Позиция №1
        End With

        'Подбиваем суммы по группам
        .PivotTables("Svodnaya").AddDataField .PivotTables _
            ("Svodnaya").PivotFields("X"), "X"  ', xlSum
        
        '=================================================================================
        'Сводная таблица создана!
        '=================================================================================

        '=================================================================================
        'Рисуем диаграмму
        '=================================================================================
        'Добавляем диаграмму (тип - xlColumnClustered) на новый лист
        xlApp.Charts.Add
        xlApp.ActiveChart.ChartType = xlColumnClustered
        xlApp.ActiveChart.PlotArea.Interior.ColorIndex = xlNone 'Обесцвечиваем подложку (фон)
        xlApp.ActiveChart.HasTitle = True 'Отображение заголовка диаграммы
        xlApp.ActiveChart.ChartTitle.Characters.Text = "Диаграмма"
        xlApp.ActiveChart.Legend.Position = xlTop 'Вывод легенды сверху диаграммы
        xlApp.ActiveSheet.Name = "Диаграмма" 'Наименование листа
        .Visible = xlSheetVeryHidden
    End With

    'Скрываем 'повылазившие' панели инструментов
    xlApp.ActiveWorkbook.ShowPivotTableFieldList = False
    xlApp.CommandBars("PivotTable").Visible = False
    xlApp.CommandBars("Chart").Visible = False
    'Сохранение файла под именем Staj.xls
    xlBook.SaveAs FileName:=CurrentProject.Path & "\Staj", _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    xlApp.DisplayAlerts = True 'Разрешаем сообщения MSExcel
   xlApp.Visible = True 'Выводим на экран
xlApp.CalculateFull
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing

Exit Sub
Err_StajInExcel:
    MsgBox Err.Description, vbCritical + vbMsgBoxHelpButton, _
        "Ошибка №" & Err.number, Err.HelpFile, Err.HelpContext
    On Error Resume Next
    xlApp.Quit
End Sub