VBA合并Excel文件代码在部分系统无法运行的问题求助

问题说明 #

以下VBA代码用于合并指定文件夹内的80多个Excel工作簿（每个含3个工作表），在我的个人笔记本、办公电脑及一位同事的系统上可正常运行，但其他同事的系统无法执行。

原代码 #

Option Explicit
 
Sub CombineFiles()
     
    Dim path            As String
    Dim Filename        As String
    Dim Wkb             As Workbook
    Dim ws              As Worksheet
     
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    path = "C:\Users\Abins\Desktop\Payment Posting VBA 19062022\Consol" 'Change as needed
    Filename = Dir(path & "\*.xls", vbNormal)
    Do Until Filename = ""
        Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
        For Each ws In Wkb.Worksheets
            ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        Next ws
        Wkb.Close False
        Filename = Dir()
    Loop
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox "Success! Press Cntrl+J"
     
End Sub

排查与解决方向 #

• 硬编码路径问题：代码中的路径是固定的，若同事系统中该路径不存在、文件夹名称有误或无读取权限，会直接失效。
  • 替换为文件夹选择功能，让用户自行选择目标文件夹：

    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = -1 Then
        path = fd.SelectedItems(1)
    Else
        MsgBox "未选择文件夹，程序退出"
        Exit Sub
    End If
    

  • 确认同事的目标文件夹路径正确，且拥有读取权限。
• 文件格式匹配限制：原代码仅匹配.xls格式，若同事的文件是.xlsx、.xlsm等格式，会被忽略。修改匹配规则：

  Filename = Dir(path & "\*.xls*", vbNormal)
  

• Excel宏安全设置：同事的Excel可能禁用了宏，或未授权VBA项目访问权限。
  • 打开Excel选项 → 信任中心 → 信任中心设置 → 宏设置，选择合适的宏启用选项；
  • 勾选"信任对VBA项目对象模型的访问"。
• 文件锁定/权限问题：目标工作簿可能被其他程序锁定，或处于只读状态。
  • 确保所有目标工作簿未被其他应用打开；
  • 打开文件时添加只读参数，避免权限冲突：

    Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename, ReadOnly:=True)
    

• 添加错误捕获定位问题：在代码中加入错误捕获，明确报错原因，方便针对性排查：

  Option Explicit
  
  Sub CombineFiles()
       
      Dim path            As String
      Dim Filename        As String
      Dim Wkb             As Workbook
      Dim ws              As Worksheet
       
      On Error GoTo ErrorHandler
      Application.EnableEvents = False
      Application.ScreenUpdating = False
      path = "C:\Users\Abins\Desktop\Payment Posting VBA 19062022\Consol" 'Change as needed
      Filename = Dir(path & "\*.xls", vbNormal)
      Do Until Filename = ""
          Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
          For Each ws In Wkb.Worksheets
              ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
          Next ws
          Wkb.Close False
          Filename = Dir()
      Loop
      Application.EnableEvents = True
      Application.ScreenUpdating = True
      
      MsgBox "Success! Press Cntrl+J"
      Exit Sub
      
  ErrorHandler:
      MsgBox "运行出错：" & Err.Description & "，错误代码：" & Err.Number
      Application.EnableEvents = True
      Application.ScreenUpdating = True
       
  End Sub
  

内容的提问来源于stack exchange，提问作者Abins Bin Mohammadali