Private Sub proba()
On Error GoTo Err1
    Dim pth As String
    Dim mdb As String
    Dim tbl As String
    Dim xls As String
    Dim lst As String

    pth = ThisWorkbook.Path & "\Подкаталог с xls"
    tbl = "Таблица1"
    
    mdb = pth & "\db1.mdb"
    
'    Dim db As ADOX.Catalog             'Microsoft ADO Ext. 2.8 for DDL and Security
'    Set db = New ADOX.Catalog
'    db.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & mdb & ";"
'    Set db = Nothing
    
    'или с помощью DAO
    Dim db As DAO.Database             'Microsoft DAO 3.6 Objects Library
    Set db = DBEngine.Workspaces( 0 ).CreateDatabase(mdb, dbLangCyrillic)
    Set db = Nothing
    
    Dim db1 As ADODB.Connection         'Microsoft ActiveX Data Objects 2.8 Library
    Set db1 = New ADODB.Connection
    db1.Provider = "Microsoft.Jet.OLEDB.4.0"
    db1.Open mdb, "Admin"
    db1.Execute "CREATE TABLE " & tbl & " (pole1 VARCHAR(30), pole2 NUMERIC(20,5))"
    
    lst = "Лист1"
    xls = Dir(pth & "\*.xls")
    
    Read_xls pth & "\" & xls, lst, db1, tbl
    
    Do While xls <> ""
        xls = Dir
        If xls <> "" And (xls Like "*.xls") Then
            Read_xls pth & "\" & xls, lst, db1, tbl
        End If
    Loop
    
    db1.Close:  Set db1 = Nothing
    
Err1:
    If Err.Number <>  0  Then
        MsgBox Err.Description
        On Error Resume Next
        db1.Close:  Set db1 = Nothing
    End If
End Sub

Sub Read_xls(ByVal xls As String, ByVal lst As String, db1 As ADODB.Connection, tbl As String)
    Dim WB As Workbook
    Dim SH As Worksheet

    Set WB = Workbooks.Open(xls)
    Set SH = WB.Sheets(lst)
    
    Dim i As Long, RowMax As Long, p1 As String, p2 As Double, p3 As Date
    With SH.UsedRange
         RowMax = .Rows.Count + .Row -  1 
    End With
    For i =  3  To RowMax
        p1 = "" & SH.Cells(i,  1 )
        p2 = Val(SH.Cells(i,  2 ))
        db1.Execute "INSERT INTO " & tbl & " VALUES ('" & p1 & "', " & p2 & ")"
    Next
    WB.Close
    Set WB = Nothing
    Set SH = Nothing
End Sub