根据单元格值从可变路径导入Excel工作簿的VBA求助

需求梳理 #

• 目标路径结构：\\Server-Name\MainFolder\SubFolder\SubSubFolder\
  • MainFolder名称固定
  • SubSubFolder取值为主工作簿B2单元格的内容
  • SubFolder可选择手动输入，或使用系统当前日期（格式示例：YYYY-MM-DD）
• 需导入的文件：Kosten.xlsx、Belege.xlsx、Zeiten.xlsx，分别对应主工作簿的FW-ProjAuswertMatSEK、FW-Bestell-Lief-Pos、FW-PrjAuswertStunden工作表

修改后的完整代码 #

Sub Import_From_Server_Path()
    Dim mainWB As Workbook
    Dim serverPath As String, mainFolder As String
    Dim subFolder As String, subSubFolder As String
    Dim fullPath As String
    
    ' 绑定主工作簿对象，避免依赖ActiveWorkbook
    Set mainWB = ThisWorkbook
    
    ' --------------------------
    ' 配置固定参数，根据实际情况修改
    serverPath = "\\Server-Name\" ' 服务器地址
    mainFolder = "MainFolder"    ' 固定的主文件夹名称
    ' --------------------------
    
    ' 获取SubSubFolder（主工作簿B2单元格的值，假设在Übersicht工作表）
    subSubFolder = mainWB.Sheets("Übersicht").Range("B2").Value
    If subSubFolder = "" Then
        MsgBox "SubSubFolder不能为空，请先填写B2单元格！", vbExclamation
        Exit Sub
    End If
    
    ' 选择SubFolder：手动输入或系统日期
    subFolder = InputBox("请输入SubFolder名称，直接回车使用当前日期（YYYY-MM-DD）：", "选择SubFolder")
    If subFolder = "" Then
        subFolder = Format(Date, "YYYY-MM-DD")
    End If
    
    ' 拼接完整路径
    fullPath = serverPath & mainFolder & "\" & subFolder & "\" & subSubFolder & "\"
    
    ' 检查路径是否存在
    If Dir(fullPath, vbDirectory) = "" Then
        MsgBox "路径不存在：" & fullPath, vbCritical
        Exit Sub
    End If
    
    ' 批量导入文件
    Import_File fullPath, "Kosten.xlsx", mainWB.Sheets("FW-ProjAuswertMatSEK"), "A:L"
    Import_File fullPath, "Zeiten.xlsx", mainWB.Sheets("FW-PrjAuswertStunden"), "A:H"
    Import_File fullPath, "Belege.xlsx", mainWB.Sheets("FW-Bestell-Lief-Pos"), "A:O"
    
    ' 回到概览工作表
    mainWB.Sheets("Übersicht").Activate
    MsgBox "文件导入完成！", vbInformation
End Sub

' 封装导入逻辑，减少重复代码
Sub Import_File(filePath As String, fileName As String, targetSheet As Worksheet, copyRange As String)
    Dim sourceWB As Workbook
    
    ' 检查文件是否存在
    If Dir(filePath & fileName) = "" Then
        MsgBox "文件不存在：" & filePath & fileName, vbExclamation
        Exit Sub
    End If
    
    ' 只读模式打开源文件
    Set sourceWB = Workbooks.Open(filePath & fileName, ReadOnly:=True)
    
    ' 直接复制数据到目标工作表，避免Select/Activate
    sourceWB.Sheets(1).Range(copyRange).Copy targetSheet.Range("A1")
    
    ' 关闭源文件，不触发保存弹窗
    sourceWB.Close SaveChanges:=False
End Sub

关键修改说明 #

1. 可变路径构建：

   • 提取固定的服务器地址和主文件夹，方便后续修改
   • 通过输入框实现SubFolder的手动输入/系统日期切换
   • 自动读取主工作簿B2单元格值作为SubSubFolder

2. 代码优化：

   • 封装Import_File子过程，减少重复代码，提升可维护性
   • 移除Select/Activate操作，直接引用对象，提升代码稳定性和执行效率
   • 增加路径、文件存在检查，提前报错避免程序崩溃
   • 以只读模式打开源文件，防止文件锁定，关闭时不弹窗询问

3. 使用注意：

   • 请根据实际环境修改serverPath和mainFolder的取值
   • 确认B2单元格所在工作表（示例中为Übersicht），若实际位置不同需对应调整

内容的提问来源于stack exchange，提问作者Atena M.