Dim db As Database
Dim td As TableDef
Dim strSQL As String
Dim ws As Workspace
Dim strPath as String 'Путь к файлу БД


Set db = CurrentDb
For Each td In db.TableDefs
 If td.Connect <>  "" Then
   strSQL = " DROP TABLE [ " & td.Name & " ] "
   DoCmd.RunSQL strSQL
 End If
Next

Set ws = DBEngine.Workspaces(0 )

Set db = ws.OpenDatabase(strPath)

For Each td In db.TableDefs
    If Not td.Name Like "Msys* " Then
        DoCmd.TransferDatabase acLink, " Microsoft Access", strPath, acTable, td.Name, td.Name, False
    End If
Next td