Не обновляется список таблиц в базе после вот этого кода

Sub ExceltoAccess()
    Worktable = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    BaseName = Worktable & "\" & ActiveWorkbook.Name & ".mdb"
    Select Case CLng(Split(Application.Version, ".")(0))
        Case Is < 12
            dbConnectStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & BaseName & ";"
        Case Is >= 12
            dbConnectStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & BaseName & ";"
    End Select
    On Error Resume Next
    Set oAccess = GetObject(, "Access.Application")
    If Err.Number = 429 Then
        Set Catalog = CreateObject("ADOX.Catalog")
        Catalog.Create dbConnectStr
        Set Catalog = Nothing
        Set cnt = New ADODB.Connection
        cnt.Open dbConnectStr
        Set rs = CreateObject("ADODB.Recordset")
        sSQL = "SELECT * INTO [" & ActiveSheet.Name & "] FROM [Excel 12.0;HDR=YES;IMEX=1;DATABASE=" & ActiveWorkbook.FullName & "].[" & ActiveSheet.Name & "$]"
        Set rs = cnt.Execute(sSQL)
        cnt.Close
        Set sAccess = CreateObject("Access.Application")
        sAccess.Visible = True
        sAccess.UserControl = True
        sAccess.OpenCurrentDataBase (BaseName)
    Else
        basepath = oAccess.CurrentDb.Name
        If Err.Number = 91 Then
            Set Catalog = CreateObject("ADOX.Catalog")
            Catalog.Create dbConnectStr
            Set Catalog = Nothing
            Set sAccess = GetObject(, "Access.Application")
            sAccess.OpenCurrentDataBase (BaseName)
        End If
        oAccess.CurrentProject.Connection.Execute "SELECT * INTO [" & ActiveSheet.Name & "] FROM [Excel 12.0;HDR=YES;IMEX=1;DATABASE=" & ActiveWorkbook.FullName & "].[" & ActiveSheet.Name & "$]"
    End If
    Err.Clear
End Sub

Но если переоткрыть базу, то все таблицы отображаются. Как исправить эту неприятность?

http://www.sql.ru/forum/1280552/ne-obnovlyaetsya-spisok-tablic-v-baze