' Выгрузка данных из БД
Public Function GetRecord(strDB, strSql, PWD, Sheet_name As String) As Variant ' функция формирующая набор записей по сформированому запросу
'On Error Resume Next
Dim i As Byte
Dim DB As DAO.Database
Dim qdfTempQuery As DAO.QueryDef
Dim rs As DAO.Recordset
Set DB = OpenDatabase(strDB, False, False, "MS Access; PWD=" & PWD) 'открытие базы данных с монопольным паролем
Set qdfTempQuery = DB.CreateQueryDef("") ' пустые кавычки означают, что запрос не будет сохранен в базе данных
With qdfTempQuery ' формируем параметры запроса
'Debug.Print strSql
.Sql = strSql ' передаем запрос на выполнение
Set rs = .OpenRecordset(dbOpenForwardOnly) 'производим запись данных
End With
Set GetRecord = rs ' передаем записанные данные функции, которая может принимать форму массива данных
Sheets(Sheet_name).Range("A2").CopyFromRecordset rs

For i = 1 To rs.Fields.Count
Sheets(Sheet_name).Cells(1, i).Value = rs.Fields(i - 1).Name
Next
End Function

Sub ADO_Demo()
' This demo requires a reference to
' the Microsoft ActiveX Data Objects 2.x Library
     Dim DBFullName As String
     Dim Cnct As String, Src As String
     Dim Connection As ADODB.Connection
     Dim Recordset As ADODB.Recordset
     Dim Col As Integer
     Cells.Clear
     ' Database information
     DBFullName = ThisWorkbook.Path & "\budget data.accdb"
     ' Open the connection
     Set Connection = New ADODB.Connection
     Cnct = "Provider=Microsoft.ACE.OLEDB.12.0;"
     Cnct = Cnct & "Data Source=" & DBFullName & ";"
     Connection.Open ConnectionString:=Cnct
     ' Create RecordSet
     Set Recordset = New ADODB.Recordset
     With Recordset
         ' Filter
         Src = "SELECT * FROM Budget WHERE Item = 'Lease' "
         Src = Src & "and Division = 'N. America' "
         Src = Src & "and Year = '2008'"
         .Open Source:=Src, ActiveConnection:=Connection
         ' Write the field names
         For Col = 0 To Recordset.Fields.Count - 1
             Range("A1").Offset(0, Col).Value = _
             Recordset.Fields(Col).Name
         Next
         ' Write the recordset
         Range("A1").Offset(1, 0).CopyFromRecordset Recordset
     End With
     Set Recordset = Nothing
     Connection.Close
     Set Connection = Nothing
End Sub