Как программно загрузить область листа Excel в уже существующую таблицу Access

Const  strNamelist = "Sheet1"
Cnct(0) = "Provider=Microsoft.ACE.OLEDB.12.0;"
Cnct(2) = "Extended Properties=""Excel 12.0;HDR=Yes"";"
strPath = Main2.TextBox2 ' файлы в папке "Прога"
If strPath = "" Then MsgBox "Папка не указана", , "Работа прервана": Exit Sub ' не указана папка
 
 Set cnn = New ADODB.Connection
 Set rst = New ADODB.Recordset
Set fso = CreateObject("Scripting.FileSystemObject")
Set folders = fso.getfolder(strPath)
Set objExel = New Excel.Application 'CreateObject("Excel.Application")
 
For Each file1 In folders.Files ' проходим по папке
' ---------------------------------------------------------
' здесь определяем имя листа, чтобы открыть рекордсет - но в файлах ,создаваемых прогой листы называются одинаково - аоэтому тратить время на открытие не будем.
' открываем коннекшн
Cnct(1) = "Data Source=" & file1.Path & ";"
' создаем SQL запрос
cnn.Open ConnectionString:=Cnct(0) & Cnct(1) & Cnct(2)
' открываем рекордсет с данными из оригинала
str2 = "select * from [" & strNamelist & "$];"
rst.Open str2, cnn, adOpenStatic

Private Type utExcelList
    sListName As String
    lRowsCount As Long
End Type
 
Public Sub sbImportEx()
Dim sExcelFilePath As String, strSql$
Dim sRange$
Dim utvListData As utExcelList
   
   sExcelFilePath = "d:\Temp\Test.xlsx"
   utvListData = GetListData(sExcelFilePath)
   If utvListData.lRowsCount < 13 Then
        MsgBox "Фаил: " & sExcelFilePath & " не содержит данных!", vbExclamation
        Exit Sub
   End If
   
   sRange = "A13:Q" & utvListData.lRowsCount
    
    strSql = "INSERT INTO 22_temp_plan " & vbCrLf & _
    "   ( Идентиф, Застройщик, Область, Район, Объект, МероприятиеПлан, ОбластьОб, РайонОб, ГодПлан, ИнвестВсего,  " & vbCrLf & _
    "   ИнестГос, ИнвестСобств, должность, ИнвестКредиты, ИнвестПрочие, ФИО, Примечания ) " & vbCrLf & _
    "SELECT F1, F2, F3, F4, F5, F6, F7, F8, F9, F10, F11, F12, F13, F14, F15, F16, F17 " & vbCrLf & _
    "FROM (SELECT * FROM [" & utvListData.sListName & "$" & sRange & "] IN '" & sExcelFilePath & "' [Excel 12.0 XML;HDR=No]) AS EXELDATA;"
    'Debug.Print strSql
    
    CurrentDb.Execute strSql, dbFailOnError
    
    MsgBox "Успешно импортировано: " & utvListData.lRowsCount - 13  & " записей.", vbInformation, "Инфо"
 
End Sub
 
 
Private Function GetListData(strPath$) As utExcelList
Dim objExcelApp As Object
Dim objWorkbook As Object
Dim objWorksheet As Object
    
    Set objExcelApp = CreateObject("Excel.Application")
    Set objWorkbook = objExcelApp.Workbooks.Open(strPath)
    Set objWorksheet = objWorkbook.Worksheets(1)
 
    GetListData.sListName = objWorksheet.Name
    ' Заполненные строки на листе
    GetListData.lRowsCount = objWorksheet.UsedRange.Rows.Count
 
    On Error Resume Next
    objWorkbook.Close
    Set objWorkbook = Nothing
    objExcelApp.Quit
    Set objExcelApp = Nothing
    Err.Clear
 
    
End Function