求打开Excel时自动定位同文件夹Access文件路径的VBA脚本

需求概述 #

替代手动选择Access文件的原有代码，实现Excel文件打开时自动定位同目录下的Access（.accdb）文件，将完整路径写入指定单元格，且支持文件夹迁移至任意位置或电脑后仍正常运行。

实现代码 #

Private Sub Workbook_Open()
    Dim excelFolderPath As String
    Dim foundAccessFile As String
    Dim targetSheet As Worksheet
    Dim targetCell As Range
    
    ' 错误处理分支
    On Error GoTo ErrorHandler
    
    ' 获取当前Excel文件所在文件夹路径
    excelFolderPath = ThisWorkbook.Path
    ' 处理Excel未保存的情况
    If excelFolderPath = "" Then
        MsgBox "请先保存当前Excel文件，无法定位同文件夹路径！", vbExclamation
        Exit Sub
    End If
    
    ' 查找文件夹下第一个.accdb格式文件
    foundAccessFile = Dir(excelFolderPath & "\*.accdb")
    
    If foundAccessFile <> "" Then
        ' 拼接完整文件路径
        foundAccessFile = excelFolderPath & "\" & foundAccessFile
        
        ' 指定目标工作表和单元格（对应原代码的Sheets(6)和命名区域File_Path）
        Set targetSheet = ThisWorkbook.Sheets(6)
        Set targetCell = targetSheet.Range("File_Path")
        
        ' 写入路径到指定单元格
        targetCell.Value = foundAccessFile
    Else
        MsgBox "当前Excel文件夹下未找到.accdb格式的Access文件！", vbInformation
    End If
    
    Exit Sub
    
ErrorHandler:
    MsgBox "错误代码：" & Err.Number & vbCrLf & "错误描述：" & Err.Description, vbCritical
End Sub

关键逻辑说明 #

• Workbook_Open事件：Excel内置触发事件，文件打开时自动执行代码
• ThisWorkbook.Path：动态获取当前Excel所在文件夹路径，不受文件夹迁移影响
• Dir函数：快速遍历指定路径下的目标格式文件，返回第一个匹配的文件名
• 异常处理：覆盖Excel未保存、目标工作表/单元格不存在等常见错误场景

使用注意事项 #

• 确保Excel与Access文件处于同一文件夹
• 若文件夹下存在多个.accdb文件，代码会自动选取第一个被检索到的文件
• 请确认原代码中的Sheets(6)和命名区域File_Path真实存在，若需调整可直接修改对应工作表名称或单元格地址

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