Private Sub Выгрузка_в_EXEL_Click()
'Объявляем переменные

Dim rst As Object
Dim xlApp As Object
Dim xlWb As Object
Dim xlWs As Object
Dim recArray As Variant

Dim strSQL As String
Dim fldCount As Integer
Dim recCount As Long
Dim iCol As Integer
Dim iRow As Integer


' Создать экземпляр Excel и добавить книгу
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Open(CurrentProject.Path & "\Шаблоны\Карты_изоляции\171201\В_вводы.xlsx")
Set xlWs = xlWb.Worksheets("Ввод")

' Вывести Excel на экран позволить пользователю управлять временем работы Excel
xlApp.Visible = True
xlApp.UserControl = True

' Скопировать имена полей в первую строку листа
'fldCount = rst.Fields.Count
'For iCol = 1 To fldCount
' xlWs.Cells(1, iCol).Value = rst.Fields(iCol - 1).Name
'Next

' Проверить версию Excel
If Val(Mid(xlApp.Version, 1, InStr(1, xlApp.Version, ".") - 1)) > 8 Then
'EXCEL 2000,2002,2003 или 2007: используется метод CopyFromRecordset

' Скопировать набор записей на лист, начиная с ячейки A21
xlWs.Cells(21, 1).CopyFromRecordset rst
'Примечание. При использовании метода CopyFromRecordset произойдет сбой, если набор записей
'содержит поле объекта OLE или массив данных, таких как
'иерархические наборы записей

Else
'EXCEL 97 или более ранней версии: Будет использоваться метод GetRows, а затем массив будет скопирован в Excel

' Скопировать набор данных в массив
recArray = rst.GetRows
'Примечание. Метод GetRows возвращает массив, индексируемый с 0, первая
'размерность которого содержит поля, а вторая
'содержит записи. Массив будет транспонирован таким образом, чтобы
'первая размерность содержала записи, обеспечивая
'правильное отображение данных при копировании в Excel

' Определить количество строк

recCount = UBound(recArray, 2) + 1 '+ 1, поскольку массив индексируется с 0


' Проверить массив на наличие недопустимого содержимого при
' копировании массива в лист Excel
'For iCol = 0 To fldCount - 1
' For iRow = 0 To recCount - 1
' ' Обработка полей Date (дата)
' If IsDate(recArray(iCol, iRow)) Then
' recArray(iCol, iRow) = Format(recArray(iCol, iRow))
' ' Обработка полей объектов OLE или полей массивов
' ElseIf IsArray(recArray(iCol, iRow)) Then
' recArray(iCol, iRow) = "Array Field"
' End If
' Next iRow 'следующая запись
'Next iCol 'следующее поле

' Транспонировать и скопировать массив в лист,
' начиная с ячейки A21
xlWs.Cells(21, 1).Resize(recCount, fldCount).Value = _
TransposeDim(recArray)
End If

' Автоматически подобрать ширину столбцов и высоту строк
'xlApp.Selection.CurrentRegion.Columns.AutoFit
'xlApp.Selection.CurrentRegion.Rows.AutoFit

' Закрыть объекты ADO
rst.Close
'cnt.Close
Set rst = Nothing
'Set cnt = Nothing

' Освободить ссылки на Excel
Set xlWs = Nothing
Set xlWb = Nothing

Set xlApp = Nothing

End Sub

Function TransposeDim(v As Variant) As Variant
' Пользовательская функция для транспонирования массива, индексируемого с 0 (v)

Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
Dim tempArray As Variant

Xupper = UBound(v, 2)
Yupper = UBound(v, 1)

ReDim tempArray(Xupper, Yupper)
For X = 0 To Xupper
For Y = 0 To Yupper
tempArray(X, Y) = v(Y, X)
Next Y
Next X

TransposeDim = tempArray


End Function