VBA, MS Access MS Access в примерах

MS Excel - Экспорт Данных запроса (с параметрами) в Excel c простым форматированием "шапки"


Private Sub ExportQueryToExlel03()
'es 14.06.2018
'MS Excel - Экспорт Данных запроса (с параметрами) в Excel c простым форматированием "шапки"
'--------------------------------------------------------------------------
Dim objExcelApp As Object, objWrkBk As Object, objWrkSht As Object
Dim qdf As DAO.QueryDef
Dim rst As DAO.Recordset
Dim i As Integer

On Error GoTo ExportQueryToExlel03_Err

'Устанавливаем запрос
    Set qdf = CurrentDb.QueryDefs("qwTest_001")
    'Установка параметров запроса (если таковые есть) типа:
    ' ... WHERE mDate Between [ДатаНачалаПериода] And [ДатаКонцаПериода]
    qdf.Parameters(0) = Me!txtДатаНачала
    qdf.Parameters(1) = Me!txtДатаОкончания

'Открываем набор записей
    Set rst = qdf.OpenRecordset
    
    
'--------------------------------------------------------------------------
'Проверка есть ли данные для вывода:
    With rst
        If .BOF = True And .EOF = True Then 'записей нет
            MsgBox "Запрос не вернул записей, экспорт прекращён!", vbExclamation, "Ошибка экспорта данных"
            GoTo ExportQueryToExlel03_Bye
        End If
    End With

'--------------------------------------------------------------------------
'Запуск MS Excel:
    Set objExcelApp = CreateObject("Excel.application")
    Set objWrkBk = objExcelApp.Workbooks.Add 'Создается новая рабочая книга.
    Set objWrkSht = objWrkBk.ActiveSheet 'Устанавливается ссылка на активный рабочий лист (1)
    'Или так (с заданием конкретного по индексу):
        'Set objWrkSht = objWrkBk.Worksheets(2)
        'objWrkSht.Activate
    objExcelApp.Visible = True
        
'Оформление "шапки" данных по названиям полей запроса:
    objWrkSht.Rows(1).RowHeight = 24 'Выставляем высоту строки "шапки"
    For i = 1 To rst.Fields.Count
        With objWrkSht.Cells(1, i)
            .Value = rst.Fields(i - 1).Name 'Имя Поля из запроса ...
            
            Select Case i
                Case 3 'Выставляем ширину столбца 3 (отдельно)
                    .Value = "Другое Название Поля:" 'Просто для примера ...
                    .ColumnWidth = 60
                Case Else 'Выставляем одинаковую ширину у остальных столбцов
                    .ColumnWidth = 20
            End Select
            
            .Borders.LineStyle = 1 'xlContinuous 'Разлиновка
            .HorizontalAlignment = -4108 'xlHAlignCenter
            .VerticalAlignment = -4108   'xlVAlignCenter
            .Interior.Color = RGB(243, 244, 245) 'Серый цвет
            .Font.Bold = True 'Ну понятно ...
        End With
    Next
        
'Вставка данных из Recordset (во вторую строчку):
    objWrkSht.Range("A2").CopyFromRecordset rst


ExportQueryToExlel03_Bye:
    'Закрываем всё за собой
    On Error Resume Next
    rst.Close
    Set rst = Nothing
    
    Set qdf = Nothing
    Set objWrkSht = Nothing
    Set objWrkBk = Nothing
    Set objExcelApp = Nothing
    Err.Clear

    Exit Sub

ExportQueryToExlel03_Err:
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in Sub: ExportQueryToExlel03 in module: [Неизвестный Модуль]", vbCritical, "Error in Application"
    Err.Clear
    Resume ExportQueryToExlel03_Bye
End Sub

Назад ToTop
L.E. 14.06.2018
Рейтинг@Mail.ru