Public Sub Join_Database()
Dim MyBase As String 'Строка подключения
Dim DB As Database   'оно самое
Dim R As Recordset   'оно самое
Dim Pth As String    'Путь к mdb
Dim tbl As String    'Имя таблицы
Dim tbl2 As String   'Имя таблицы
Dim i, j As Long     'Енто для цикла
Dim par As Boolean
SQQ = True
Set DB = CurrentDb()
  
Set R = DB.OpenRecordset("TablesDefine", dbOpenTable)      'таблица с исходными данными

j = R.RecordCount                                'определения количества проходов для подключения таблиц

For i = 1 To j Step 1                                'цикл перебора путей и таблиц из _base_path
    Pth = R![Path] & R![base]                        'смотрим путь к базе данных
    tbl = R![Tables]                                 'смотрим имя таблицы
    tbl2 = IIf(IsNull(R![TablesN]), "", R![TablesN]) 'смотрим имя таблицы
    par = R![IsNew]
    If R![SQQ] Then
        MyBase = R![Path] & ";DATABASE=" & R![base]
    Else
        MyBase = ";DATABASE=" & Pth              'определяем строку пути к базе данных
    End If
        a = SysCmd(SYSCMD_SETSTATUS, "* Присоединяем таблицу [" & tbl & "]  { " & MyBase & " }")
        Call Conn_Tbl(tbl, tbl2, MyBase, par)          'вызов функции подключения выбранной таблицы
    R.MoveNext                                   'переходим на следующую запись таблицы _base_path
Next i

a = SysCmd(SYSCMD_SETSTATUS, " ")

End Sub

Private Function Conn_Tbl(tblName, tblName2, MyBase As String, par As Boolean)
Dim MyTable As TableDef, txtt As String
Dim DB As Database, dbsTbl As Database   'оно самое
Dim R As Recordset, tblDefine As Recordset, tdfEdit As TableDef, fldNew As Field
On Error Resume Next                                     'Выключение обработчика ошибок
    DoCmd.DeleteObject acTable, IIf(Len(tblName2) = 0, tblName, tblName2)
                                                         'Удаление таблицы, если она есть
    Err = 0                                              'Очистка кода ошибки.

On Error GoTo Error
    Set MyTable = CurrentDb.CreateTableDef(IIf(Len(tblName2) = 0, tblName, tblName2))
    MyTable.Connect = MyBase                             'Задаем строку подключения
    MyTable.SourceTableName = tblName                    'Задаем имя исходной таблицы
    CurrentDb.TableDefs.Append MyTable                   'Присоединение таблицы
Set MyTable = Nothing                                    'Очистка
Exit Function                                            'Все тип-топ. Вываливаемся из функции

Error:
If par Then
    Set DB = CurrentDb()
    Set R = DB.OpenRecordset("TablesDefine", dbOpenDynaset)       ', dbOpenTable)
    Set tblDefine = DB.OpenRecordset("TablesStructure", dbOpenDynaset)
    txtt = "[Tables] = '" & tblName & "'"
    R.MoveFirst
    R.FindFirst txtt
    Set dbsTbl = DBEngine.Workspaces(0).OpenDatabase(R![Path] & R![base])
    Set tdfEdit = dbsTbl.CreateTableDef(tblName)
    txtt = "[TablesName] = '" & tblName & "'"
    tblDefine.FindFirst txtt
    Do While Not tblDefine.NoMatch
        Set fldNew = tdfEdit.CreateField(tblDefine![Name], tblDefine![Type])
        fldNew.Size = tblDefine![Size]
        fldNew.Attributes = tblDefine![Attributes]
        fldNew.Required = tblDefine![Required]
        tdfEdit.Fields.Append fldNew
        tblDefine.FindNext txtt
    Loop
    dbsTbl.TableDefs.Append tdfEdit        'добавляем созданную таблицу в cемейство таблиц БД
    dbsTbl.TableDefs.Refresh           'обновляем cемейство таблиц
    R.Edit
    R![IsNew] = False
    R.Update
    R.Close
    tblDefine.Close
    dbsTbl.Close
    DB.Close
    Set dbsTbl = Nothing
    Set tdfEdit = Nothing
    Set R = Nothing
    Set DB = Nothing
    Set tblDefine = Nothing
    
    Set MyTable = CurrentDb.CreateTableDef(tblName)
    MyTable.Connect = MyBase                             'Задаем строку подключения
    MyTable.SourceTableName = tblName                    'Задаем имя исходной таблицы
    CurrentDb.TableDefs.Append MyTable                   'Присоединение таблицы
Else
    MsgBox "Ошибка BB$0002 *** Невозможно подключение таблицы [" & tblName & "]" 'Сообщение об ошибке подключения
End If
End Function