Экспорт из Access в Excel

[quote="Eugene-LS;17683128"]' Вставка данных
    vVal = "SELECT Вид, Модель, Зав№СИ AS Зав, ДиапазонСИ AS Значение, ЕдИзмерения, " & vbCrLf & _
                "КлассТочности, МесяцПов, МестоСредаИзмНазначения AS Место" & vbCrLf & _
            "FROM zСредстваИзмеренияОбщий" & vbCrLf & _
            "WHERE ((ФлВыводГ=-1) AND (ФлСкрытьСтСИ=0) AND (ГодПов='" & Me!ВыборГода & "') " & _
                "AND (Лаборатория= '" & Me!ВыборЛаборатории & "'))" & vbCrLf & _
            "ORDER BY Зав№СИ, ДиапазонСИ, МесяцПов;"
    'Debug.Print vVal
    Set rs = CurrentDb.OpenRecordset(vVal, 4) ' dbOpenSnapshot = 4
'Проверка есть ли данные для вывода:
    With rs
        If .BOF = True And .EOF = True Then 'записей нет
            MsgBox "Запрос не вернул записей, экспорт прекращён!", vbExclamation, "Ошибка экспорта данных"
            GoTo MakeReport_Bye
        End If
        .MoveLast
            lRecCount = rs.RecordCount 'кол-во записей в наборе (принимаемых строк)
        .MoveFirst
    End With[/quote]

' ----------------------------------------------------------------------------------------/
' Name:      modRunMe - Именно внешний модуль!!! - никаких модулей книги ("ThisWorkbook")!
' Kind:      Module
' Purpose:   Запуск после открытия шаблона
' Author:    es
' Date:      11.12.2025
' ----------------------------------------------------------------------------------------/
Option Explicit
 
Public Function FillTemplate(ibjForm As Object, ibjRecordset As Object) As Long
' Заполнение шаблона по данным формы MS Access <ibjForm>
' Возвращает кол-во табличных записей (не код ошибки пока)
' ----------------------------------------------------------------------------------------/
' Аргументы:
'   ibjForm       = Форма MS Access
'   ibjRecordset  = Recordset (Любой с .MoveLast и .MoveFirst)
' ----------------------------------------------------------------------------------------/
Dim objSheet As Worksheet, objRange As Range, objRangeDst As Range
Dim sVal As String, lVal As Long, lRecNo As Long, lRow As Long, lRecCount As Long
Dim lLastTableRow As Long
Const clFirstTableRow As Long = 9                    ' Номер первой строки таблицы в шаблоне
 
On Error GoTo FillTemplate_Err
' ----------------------------------------------------------------------------------------/
    Set objSheet = ThisWorkbook.Worksheets(1)       ' Устанавливается ссылка на активный рабочий лист
' ----------------------------------------------------------------------------------------/
' Подсчёт записей в переданном наборе - для добавления новых строк под него (в шаблоне всего одна)
    ibjRecordset.MoveLast                           ' Переход на последнюю запись для точного подсчёта записей
    lRecCount = ibjRecordset.RecordCount            ' Кол-во записей в наборе (принимаемых строк)
    ibjRecordset.MoveFirst                          ' Возврат на первую запись - иначе не взлетит!
' Установки для формата табличных данных:
    lVal = lRecCount + (clFirstTableRow - 1)        ' Номер последней строки таблицы в шаблоне
    lLastTableRow = lVal                            ' Номер последней строки таблицы в шаблоне
' ----------------------------------------------------------------------------------------/
' Заполнение Шаблона:
' ----------------------------------------------------------------------------------------/
' Заголовок:
' - Заголовок слева = ЛАБА! - Вторая строка - Второй столбец
    objSheet.Cells(2, 2) = ibjForm.ВыборЛаборатории
' - Заголовок справа Текст! - В рукопашную!... Вторая строка - 7-й столбец
    objSheet.Cells(2, 7) = "цех № 57, Кот. № 4, КИПиА"
' - Заголовок середина - 6-я строка - Данные из формы:
    objSheet.Cells(6, 2) = "в: " & ibjForm.ВыборГода & " г."
' ----------------------------------------------------------------------------------------/
' Заполнение Таблицы:
 
' - Добавлям строки под данные таблицы ..... (xlDown=-4121 + xlFormatFromRightOrBelow = 1)
    For lVal = 1 To lRecCount - 1
        objSheet.Range("B9:J9").Insert -4121, 1
    Next lVal
' - Вставка данных из Recordset (9-я строка и 3-й столбец ):
    objSheet.Cells(clFirstTableRow, 3).CopyFromRecordset ibjRecordset
 
' - Нумерация записей в таблице (Столбец "№")
    lRecNo = 0
    For lRow = clFirstTableRow To lLastTableRow
        lRecNo = lRecNo + 1
        objSheet.Cells(lRow, 2) = lRecNo  ' Номер по порядку
    Next lRow
 
' - Отмена индикации первых 7-ми ошибок в диапазоне ячеек (всего 12)
    sVal = "B" & clFirstTableRow & ":J" & lLastTableRow
    Set objRange = objSheet.Range(sVal)
    For Each objRangeDst In objRange.Cells
        For lVal = 1 To 7
           objRangeDst.Errors(lVal).Ignore = True
        Next
    Next
' ----------------------------------------------------------------------------------------/
' Заполнение подвала  ...
' ----------------------------------------------------------------------------------------/
' Подпись 01 lVal-я строка - 3-й и 10-й столбец
    lVal = lRecCount + 12 ' Строка
    objSheet.Cells(lVal, 3) = "Начальник  цеха № 57"       ' Текст! - В рукопашную!
    objSheet.Cells(lVal, 10) = "В.В. Соколов"              ' Текст! - В рукопашную!
' Подпись 02
    lVal = lVal + 5 ' Строка
    objSheet.Cells(lVal, 3) = "Начальник  участка  КИПиА"  ' Текст! - В рукопашную!
    objSheet.Cells(lVal, 10) = "О.В. Соколов"              ' Текст! - В рукопашную!
    
    FillTemplate = lRecNo
 
FillTemplate_End:
    Set objRange = Nothing: Set objSheet = Nothing
    Exit Function
 
FillTemplate_Err:
    MsgBox "Error " & Err.Number & " - " & Err.Description & vbCrLf & _
           "In Function: FillTemplate - ThisWorkbook.", vbCritical, "Error!"
    Debug.Print "FillTemplate_Line: " & Erl & "."
    Err.Clear
    Resume FillTemplate_End
End Function

Private Sub КнЭкспортВExcel_Click() ' Событие кнопки: "Экспорт в Excel"
Dim objExcelApp As Object, objWBook As Object
Dim sVal, lVal&, sTemplatePath$
Dim rs As DAO.Recordset
    
    Const csTemplateFile$ = "Поверка КИПиА_v04.xls" ' Имя файла шаблона находящегося в папке приложения
'--------------------------------------------------------------------------------------------------------
On Error GoTo MakeReport_Err
 
' Тут проверки на значений
    sTemplatePath = CurrentProject.Path & "\" & csTemplateFile
    If Dir(sTemplatePath) = "" Then
        MsgBox "Шаблон: " & vbCrLf & sTemplatePath & vbCrLf & "Не Найден!", vbExclamation
        Exit Sub
    End If
    
    If Me.ВыборГода.ListIndex = -1 Then
        MsgBox "А год выбрать - Забыли!", vbExclamation
        Me.ВыборГода.SetFocus:  Me.ВыборГода.Dropdown
        Exit Sub
    End If
    
    If Me.ВыборЛаборатории.ListIndex = -1 Then
        MsgBox "А лабу выбирать - Я за вас должен!", vbExclamation
        Me.ВыборЛаборатории.SetFocus: Me.ВыборЛаборатории.Dropdown
        Exit Sub
    End If
 
' Подготовка Recordset к передаче
    sVal = "SELECT Вид, Модель, Зав№СИ AS Зав, ДиапазонСИ AS Значение, ЕдИзмерения, " & vbCrLf & _
                "КлассТочности, МесяцПов, МестоСредаИзмНазначения AS Место" & vbCrLf & _
            "FROM zСредстваИзмеренияОбщий" & vbCrLf & _
            "WHERE ((ФлВыводГ=-1) AND (ФлСкрытьСтСИ=0) AND (ГодПов='" & Me!ВыборГода & "') " & _
                "AND (Лаборатория= '" & Me!ВыборЛаборатории & "'))" & vbCrLf & _
            "ORDER BY Зав№СИ, ДиапазонСИ, МесяцПов;"
    'Debug.Print sVal
    Set rs = CurrentDb.OpenRecordset(sVal, dbOpenSnapshot) ' (dbOpenSnapshot = 4 если что ...)
 
' Проверка есть ли данные для вывода:
    With rs
        If .BOF = True And .EOF = True Then 'записей нет
            MsgBox "Запрос не вернул записей, экспорт прекращён!", vbExclamation, "Ошибка экспорта данных"
            GoTo MakeReport_Bye
        End If
    End With
 
' Енд оф проверки на значения
'--------------------------------------------------------------------------------------------------------
    DoCmd.Hourglass True 'Показать часики
'--------------------------------------------------------------------------------------------------------
' Запуск нового экземпляра Excel
    Set objExcelApp = CreateObject("Excel.Application")
    objExcelApp.WindowState = -4140 ' (-4140 = xlMinimized)
    objExcelApp.Visible = True
    Set objWBook = objExcelApp.Workbooks.Open(sTemplatePath) ' Открытие шаблона:
    objWBook.Application.DisplayAlerts = False               ' Отмена сообщений совместимости и прочего
 
'--------------------------------------------------------------------------------------------------------
' Запуск Функции из ШАБЛОНА!
     lVal = objExcelApp.Application.Run("FillTemplate", Me.Form, rs)
     
' ----------------------------------------------------------------------------------------/
'Сохранение файла на диске.
    sVal = CurrentProject.Path & "\ExportNew_" & Format(Now, "yyyy-mm-dd hh-nn-ss") & ".xls"
    objWBook.SaveAs sVal
 
    DoCmd.Hourglass False 'Вернуть нормальный курсор
    MsgBox "Готово!" & vbCrLf & "Успешно экспортировано: " & lVal & " записей." & vbCrLf & _
        "Файл: " & sVal, vbInformation, "Экспорт в шаблон Excel"
 
    objExcelApp.DisplayAlerts = True ' вкл. сообщений совместимости и прочего
    objExcelApp.WindowState = -4137  ' -4137 = xlMaximized (во весь экран)
    AppActivate objExcelApp.Caption  ' Делает активным окно приложения
 
MakeReport_Bye:
    If rs Is Nothing = False Then rs.Close
    Set rs = Nothing:  Set objWBook = Nothing: Set objExcelApp = Nothing
    Exit Sub
 
MakeReport_Err:
    DoCmd.Hourglass False 'Вернуть нормальный курсор
    If objExcelApp Is Nothing = False Then objExcelApp.Visible = True
    MsgBox "Ошибка " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
        "в процедуре: ""Экспорт в шаблон Excel""", vbCritical, "Error"
    Resume MakeReport_Bye
End Sub