如何通过VBA实现Access前端同时重新链接两个独立后端？

• 有两个Access前端数据库：Rolodex（存储客户信息及相关工作记录）、Timeclock（存储员工考勤、工时、薪资标准，用于生成各类表单报表）
• 前端需在办公室服务器（G盘）和家中桌面（C盘）切换使用，两处的前端和后端均位于同一文件夹内
• 已创建表存储4条后端路径：
  • C:\users\bobbye\desktop\rolodex_be
  • C:\users\bobbye\desktop\timeclock_be
  • G:\rolodex_be
  • G:\timeclock_be
• Rolodex前端仅连接Rolodex_be后端，现有VBA重链接函数运行正常；但Timeclock前端需同时连接Timeclock_be和Rolodex_be两个后端，复制相同代码后，选择Timeclock_be时无法成功链接，也无法继续处理Rolodex_be的链接

你当前的Relinktables函数会把所有链接表统一修改为同一个LnkDataBase路径。比如Timeclock里原本连接Rolodex_be的表，会被强行替换成Timeclock_be的路径，导致这些表链接失效，自然无法完成后续操作。

由于你的前端和后端始终在同一文件夹，我们可以直接获取当前前端所在的文件夹路径，自动匹配对应后端，无需手动重复选择，操作更简单。

修改后的VBA代码 #

Public Sub RelinkAllTables()
    Dim dbs As DAO.Database
    Dim tdf As DAO.TableDef
    Dim frontEndPath As String
    Dim backEndPath_Rolodex As String
    Dim backEndPath_Timeclock As String
    
    ' 获取当前前端所在的文件夹路径
    frontEndPath = CurrentProject.Path & "\"
    
    ' 拼接两个后端的完整路径（和你存储的后端文件名保持一致）
    backEndPath_Rolodex = frontEndPath & "rolodex_be"
    backEndPath_Timeclock = frontEndPath & "timeclock_be"
    
    Set dbs = CurrentDb()
    
    For Each tdf In dbs.TableDefs
        ' 只处理Access链接表，跳过ODBC类型的表
        If Len(tdf.Connect) > 1 And Left(tdf.Connect, 4) <> "ODBC" Then
            ' 根据表原本链接的后端名称，匹配对应新路径
            If InStr(tdf.Connect, "rolodex_be") > 0 Then
                tdf.Connect = ";DATABASE=" & backEndPath_Rolodex
                tdf.RefreshLink
            ElseIf InStr(tdf.Connect, "timeclock_be") > 0 Then
                tdf.Connect = ";DATABASE=" & backEndPath_Timeclock
                tdf.RefreshLink
            End If
        End If
    Next tdf
    
    MsgBox "所有表重链接完成！", vbInformation
End Sub

使用说明 #

1. 将原有Relinktables函数替换为上述代码
2. 直接运行该宏即可，无需手动选择文件——它会自动识别当前前端在办公室还是家中，匹配对应文件夹下的两个后端
3. 确保后端文件名不变：必须是rolodex_be和timeclock_be，和你之前存储的路径一致

备选方案（手动选择两个后端） #

如果偏好手动选择路径，可以添加两个文件选择框，分别指定两个后端位置：

Public Sub RelinkBySelect()
    Dim dbs As DAO.Database
    Dim tdf As DAO.TableDef
    Dim path_Rolodex As String
    Dim path_Timeclock As String
    Dim fd As FileDialog
    
    ' 选择Rolodex后端数据库
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Title = "选择Rolodex后端数据库"
        .Filters.Add "Access数据库", "*.accdb;*.mdb"
        If .Show = -1 Then
            path_Rolodex = .SelectedItems(1)
        Else
            MsgBox "未选择Rolodex后端，取消操作", vbExclamation
            Exit Sub
        End If
    End With
    
    ' 选择Timeclock后端数据库
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Title = "选择Timeclock后端数据库"
        .Filters.Add "Access数据库", "*.accdb;*.mdb"
        If .Show = -1 Then
            path_Timeclock = .SelectedItems(1)
        Else
            MsgBox "未选择Timeclock后端，取消操作", vbExclamation
            Exit Sub
        End If
    End With
    
    Set dbs = CurrentDb()
    
    For Each tdf In dbs.TableDefs
        If Len(tdf.Connect) > 1 And Left(tdf.Connect, 4) <> "ODBC" Then
            If InStr(tdf.Connect, "rolodex_be") > 0 Then
                tdf.Connect = ";DATABASE=" & path_Rolodex
                tdf.RefreshLink
            ElseIf InStr(tdf.Connect, "timeclock_be") > 0 Then
                tdf.Connect = ";DATABASE=" & path_Timeclock
                tdf.RefreshLink
            End If
        End If
    Next tdf
    
    MsgBox "所有表重链接完成！", vbInformation
End Sub

内容的提问来源于stack exchange，提问作者Bobbyer