VBA归档工作簿遇'File in Use'错误，请求排查代码问题

我有一个名为“Master”的工作簿，需要将其复制到归档目录。由于每周可能多次运行这个程序，会用最新副本覆盖对应时段的已归档版本，但偶尔会触发标准的“File in Use”错误，仅提示“另一用户”占用，未指明具体用户。想确认是否是我的VBA代码导致Excel进程挂起，代码中是否存在引发该问题的因素？

Sub ClientPrep()

    Dim wbTarget As Workbook
    Dim strPathBin As String
    Dim strSSPath As String
    Dim strTab As String
      
    With Application
        .DisplayAlerts = False
        .AskToUpdateLinks = False
        .AlertBeforeOverwriting = False
        .ScreenUpdating = False
        .Calculation = xlManual
    End With
    
    dd = Format(Now, "dd")
    mm = Format(Now, "mm")
    m = Format(Now, "m")
    q = Format(Now, "q")
    yy = Year(Now)

    '''
    Sheets("Results").Activate
    WeekEndDate = Application.WorksheetFunction.Max(Columns("F"))
    WeekEndDate = Format(WeekEndDate, "mm-dd-yyyy")
    
    Sheets("Cover Page").Activate
    
    strPathBin = ""
    strSSPath = ActiveWorkbook.Path & "\_Client_Copy\" & WeekEndDate & "\"

    '::-- Set batch variables --::'
    Shell ("cmd.exe /C SETx ClientCopyBin " & "_Client_Copy\" & WeekEndDate & "\")
    Shell ("cmd.exe /C SETx WeekEndDate " & WeekEndDate)

    '::-- Create Archive Directory --::'
    If Dir(strSSPath, vbDirectory) = "" Then
        Shell ("cmd /c mkdir """ & strSSPath & """")
    End If

    '::-- Copy Files to Archive Directory --::'
    Application.Wait (Now + TimeValue("00:00:02")) 'wait 2 seconds from now

    '::-- Get Client Name --::'
    On Error Resume Next
    strString = Replace(ThisWorkbook.Worksheets("Cover Page").Range("C2"), " ", "_")
    
    If Err.Number <> 0 Then
        Exit Sub
    End If
       
    strName = WeekEndDate & "_" & strString & "_Hours_Report.xlsm"
                        
    '::-- Remove Worbook if Exist --::'
    If Dir(strSSPath & strName) <> "" Then Kill strSSPath & strName

    '::-- Make Workbook Copy --::'
    ActiveWorkbook.SaveCopyAs strSSPath & strName
    
    '::-- Open Client Workbook --::'
    Set wbTarget = Workbooks.Open(strSSPath & strName)

    '::-- Hide Period Tabs if no data exists --::'
    Dim i As Integer
    For i = 1 To 12
    
        strTab = "P" & i
        
        Sheets(strTab).Cells.Copy
        Sheets(strTab).Cells.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        
        If i > m Then wbTarget.Worksheets(strTab).Visible = xlSheetHidden
        
        wbTarget.Worksheets(strTab).Range("B:B").EntireColumn.AutoFit
        Sheets(strTab).Activate
        ActiveSheet.Cells(1, 1).Select
    Next
             
    For i = 1 To 4
        
        strTab = "Q" & i
        
        Sheets(strTab).Cells.Copy
        Sheets(strTab).Cells.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
                
        If i > q Then wbTarget.Worksheets(strTab).Visible = xlSheetHidden
        
        wbTarget.Worksheets(strTab).Range("B:B").EntireColumn.AutoFit
        Sheets(strTab).Activate
        ActiveSheet.Cells(1, 1).Select
        
    Next i
    
    Sheets("Overage_Tracker").Cells.Copy
    Sheets("Overage_Tracker").Cells.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    ActiveSheet.Cells(1, 1).Select
                 
    '::-- Clear Results Tab --::'
    wbTarget.Worksheets("Results").Cells.Clear

    
    '::-- Hide Sheets --::'
    On Error Resume Next
    wbTarget.Worksheets("Contract").Visible = xlSheetHidden
    wbTarget.Worksheets("Results").Visible = xlSheetHidden
    wbTarget.Worksheets("Overage_Tracker").Visible = xlSheetHidden
    wbTarget.Worksheets("Instructions").Visible = xlSheetHidden
    wbTarget.Worksheets("Task").Visible = xlSheetHidden
    wbTarget.Worksheets("Rate_Card").Visible = xlSheetHidden
    wbTarget.Worksheets("Non-Standard_Tracker").Visible = xlSheetHidden
    On Error GoTo 0
    
    wbTarget.Worksheets("Cover Page").Activate
    wbTarget.Save: wbTarget.Close
    ActiveWorkbook.Worksheets("Cover Page").Activate
    
End Sub

• Shell命令异步执行的不确定性：你用Shell调用cmd创建目录、设置环境变量，但Shell默认是异步运行的——VBA代码不会等cmd命令执行完成就继续往下走。比如创建目录的命令还没跑完，后面就开始尝试删除、复制文件，这时目录/文件可能还被cmd进程占用，直接触发“File in Use”错误。你加的2秒等待只是硬延时，完全不可靠，不同系统、不同负载下执行时间差异很大。
• 工作表引用混乱导致资源泄漏：代码里大量使用Sheets("xxx").Activate和ActiveSheet，但这里的Sheets有时候指向原工作簿（Master），有时候应该指向打开的wbTarget。比如处理P1-P12工作表时，你复制的是原工作簿的单元格，却设置wbTarget的工作表可见性，这种交叉引用会导致Excel对象模型混乱，甚至残留未释放的进程，长期占用文件。
• Kill命令无错误处理：用Kill删除旧文件时，没有检查文件是否真的处于未被占用状态。如果之前的程序运行异常，文件还被残留的Excel进程占用，Kill会失败，但你没做任何处理，后续的SaveCopyAs就会因为文件被占用报错。
• 错误处理滥用掩盖问题：On Error Resume Next会掩盖很多隐性错误，比如获取客户端名称时如果C2单元格出问题，直接Exit Sub，但之前打开的对象、修改的Excel设置都没恢复；后面隐藏工作表的On Error Resume Next也会掩盖工作表不存在的错误，导致资源无法正确清理。
• 未恢复Excel应用程序状态：代码开头修改了DisplayAlerts、Calculation等设置，但结束时没有恢复成原来的值，这会导致Excel一直处于异常状态，后续操作容易出问题，甚至进程挂起。

Sub ClientPrep()
    Dim wbMaster As Workbook
    Dim wbTarget As Workbook
    Dim strSSPath As String
    Dim strTab As String
    Dim WeekEndDate As String
    Dim strString As String
    Dim strName As String
    Dim i As Integer
    ' 保存原始Excel设置
    Dim origDisplayAlerts As Boolean
    Dim origAskToUpdateLinks As Boolean
    Dim origAlertBeforeOverwriting As Boolean
    Dim origScreenUpdating As Boolean
    Dim origCalculation As XlCalculation
    
    Set wbMaster = ThisWorkbook
    ' 保存原始设置
    With Application
        origDisplayAlerts = .DisplayAlerts
        origAskToUpdateLinks = .AskToUpdateLinks
        origAlertBeforeOverwriting = .AlertBeforeOverwriting
        origScreenUpdating = .ScreenUpdating
        origCalculation = .Calculation
        
        .DisplayAlerts = False
        .AskToUpdateLinks = False
        .AlertBeforeOverwriting = False
        .ScreenUpdating = False
        .Calculation = xlManual
    End With
    
    On Error GoTo Cleanup ' 结构化错误处理
    
    ' 获取周结束日期
    WeekEndDate = Format(Application.WorksheetFunction.Max(wbMaster.Worksheets("Results").Columns("F")), "mm-dd-yyyy")
    
    ' 构建归档路径
    strSSPath = wbMaster.Path & "\_Client_Copy\" & WeekEndDate & "\"
    
    ' 创建目录（用VBA原生方法，替代Shell）
    If Dir(strSSPath, vbDirectory) = "" Then
        MkDir strSSPath
    End If
    
    ' 获取客户端名称
    strString = Replace(wbMaster.Worksheets("Cover Page").Range("C2").Value, " ", "_")
    strName = WeekEndDate & "_" & strString & "_Hours_Report.xlsm"
    
    ' 删除旧文件（增加重试机制）
    Dim retryCount As Integer
    retryCount = 3
    Do While retryCount > 0
        On Error Resume Next
        Kill strSSPath & strName
        If Err.Number = 0 Then Exit Do
        Err.Clear
        retryCount = retryCount - 1
        Application.Wait Now + TimeValue("00:00:01")
    Loop
    On Error GoTo Cleanup
    If retryCount = 0 Then
        MsgBox "无法删除旧文件，可能被占用", vbCritical
        GoTo Cleanup
    End If
    
    ' 复制工作簿
    wbMaster.SaveCopyAs strSSPath & strName
    
    ' 打开目标工作簿
    Set wbTarget = Workbooks.Open(strSSPath & strName)
    
    ' 处理月度工作表
    For i = 1 To 12
        strTab = "P" & i
        With wbTarget.Worksheets(strTab)
            ' 转成值
            .Cells.Value = .Cells.Value
            ' 隐藏未来月份
            If i > Val(Format(Now, "m")) Then .Visible = xlSheetHidden
            ' 自动调整列宽
            .Range("B:B").EntireColumn.AutoFit
        End With
    Next i
    
    ' 处理季度工作表
    For i = 1 To 4
        strTab = "Q" & i
        With wbTarget.Worksheets(strTab)
            .Cells.Value = .Cells.Value
            If i > Val(Format(Now, "q")) Then .Visible = xlSheetHidden
            .Range("B:B").EntireColumn.AutoFit
        End With
    Next i
    
    ' 处理Overage_Tracker
    With wbTarget.Worksheets("Overage_Tracker")
        .Cells.Value = .Cells.Value
    End With
    
    ' 清空Results表
    wbTarget.Worksheets("Results").Cells.Clear
    
    ' 隐藏指定工作表
    Dim hiddenSheets As Variant
    hiddenSheets = Array("Contract", "Results", "Overage_Tracker", "Instructions", "Task", "Rate_Card", "Non-Standard_Tracker")
    For Each strTab In hiddenSheets
        On Error Resume Next
        wbTarget.Worksheets(strTab).Visible = xlSheetHidden
        On Error GoTo Cleanup
    Next strTab
    
    ' 保存并关闭目标工作簿
    wbTarget.Save
    wbTarget.Close SaveChanges:=False
    
Cleanup:
    ' 恢复Excel原始设置
    With Application
        .DisplayAlerts = origDisplayAlerts
        .AskToUpdateLinks = origAskToUpdateLinks
        .AlertBeforeOverwriting = origAlertBeforeOverwriting
        .ScreenUpdating = origScreenUpdating
        .Calculation = origCalculation
    End With
    
    ' 释放对象
    Set wbTarget = Nothing
    Set wbMaster = Nothing
    
    If Err.Number <> 0 Then
        MsgBox "程序出错：" & Err.Description, vbCritical
        Err.Clear
    End If
End Sub

1. 用VBA原生MkDir替代Shell创建目录，避免异步执行的问题。
2. 明确指定工作簿对象（wbMaster、wbTarget），彻底抛弃Activate和ActiveSheet，避免对象引用混乱。
3. 为Kill命令增加重试机制，应对临时文件占用的情况。
4. 采用结构化错误处理（On Error GoTo Cleanup），确保出错时能恢复Excel设置、释放所有对象。
5. 保存并恢复Excel原始设置，避免影响后续操作。
6. 用.Cells.Value = .Cells.Value替代复制粘贴转值，更高效且避免剪贴板占用。

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