Sub выбрать_1()

Dim connDB As New ADODB.Connection
Dim rs As New ADODB.Recordset

Dim err As ADODB.Error
Dim res As Variant

Dim ws As Worksheet

Dim sPath, sTable As String
Dim i As Byte

On Error GoTo ErrorSub

sPath = " M:\ÒÅÍÍÈÑ\Ìóæ÷èíû\Ìóæ÷èíû_Òåííèñ.accdb"

Set ws = Worksheets("1")

sTable = "1"

connDB.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sPath
connDB.Open

Set rs = connDB.Execute("SELECT * FROM " & sTable)

For i = 1 To rs.Fields.Count
ws.Cells(3, i).Value = rs.Fields(i - 1).Name
Next i

ws.Range("A4:K200").ClearContents

ws.Range("A4").CopyFromRecordset rs

ErrorSub:
For Each err In connDB.Errors
res = MsgBox(err.Description & Chr(13) & Chr(13) & "Èñòî÷íèê îøèáêè: " & err.Source, , " Îøèáêè ðàáîòû ñ áàçîé äàííûõ !")
Next

ClearMemory:

rs.Close
connDB.Close
Set rs = Nothing
Set connDB = Nothing

End Sub

Sub выбрать_1()
      Const sPath$ = "d:\Desktop\Реестр договоров.accdb"
      Dim sConn, oRS As Object
10    sConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sPath
20    On Error GoTo err
30    Set oRS = CreateObject("adodb.recordset")
40    For i = 1 To 5
50        rr = oRS.Open("select * from " & i, sConn)
60        With Sheets(i & "")
70            .UsedRange.Delete
80            With .ListObjects.Add(xlSrcQuery, oRS, , , .[A1])
90                .Refresh: .Unlink
100           End With
110       End With
120       oRS.Close
130   Next
140   Set oRS = Nothing
150   On Error GoTo 0
160   Exit Sub
err:
170    MsgBox "An error #" & err.Number & " (" & err.Description & ") has occurred in procedure выбрать_1 on line " & Erl
End Sub