如何优化多用户场景下的VBA跨工作表数据复制保存代码？

问题背景 #

现有VBA代码用于将登录工作簿中“Scheduled Ad”工作表的指定数据复制到主工作簿“RTS Report.Xlsb”的“Day In”工作表，当前有65名用户同时使用登录工作簿。原代码通过循环等待主工作簿解除只读状态完成操作，但存在两个核心问题：

1. 用户未等待循环结束就强制关闭Excel，导致主工作簿被锁定在只读模式，其他用户陷入无限循环等待；
2. 偶尔出现运行时错误380（无效属性值），且主工作簿可能被用户意外打开。

核心问题分析 #

• 原循环无超时限制，异常退出时未正确释放主工作簿的文件锁；
• 过度依赖Activate/Select操作，容易触发属性错误，代码稳定性差；
• 依赖剪贴板完成数据复制，效率低且可能与用户操作冲突；
• 未设置错误捕获机制，出错后会导致工作表保护未恢复、文件未关闭等遗留问题。

重构优化后的代码 #

Sub RTS_Updated()
    Dim sourceWs As Worksheet
    Dim targetWb As Workbook
    Dim targetWs As Worksheet
    Dim filePath As String
    Dim waitStartTime As Date
    Const MAX_WAIT_MINUTES As Integer = 5 ' 最大等待5分钟，可按需调整
    Const PROTECT_PWD As String = "GLOLOGIN"
    
    ' 初始化应用环境
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False ' 禁用事件避免干扰
    End With
    
    On Error GoTo Cleanup ' 设置全局错误捕获
    
    ' 绑定源工作表，避免Activate/Select操作
    Set sourceWs = ThisWorkbook.Worksheets("Scheduled Ad")
    sourceWs.Unprotect PROTECT_PWD
    
    ' 拼接并验证目标文件路径
    filePath = Trim(sourceWs.Range("Y2").Value) & "\" & Trim(sourceWs.Range("AC2").Value)
    If Dir(filePath) = "" Then
        MsgBox "目标文件路径无效，请检查Y2和AC2单元格内容", vbExclamation
        GoTo Cleanup
    End If
    
    ' 循环尝试以可写模式打开文件，带超时限制
    waitStartTime = Now
    Do
        Set targetWb = Workbooks.Open(Filename:=filePath, ReadOnly:=False, IgnoreReadOnlyRecommended:=True)
        If Not targetWb.ReadOnly Then Exit Do
        
        ' 只读模式下关闭文件，等待2秒后重试
        targetWb.Close SaveChanges:=False
        Set targetWb = Nothing
        
        ' 检查是否超时
        If DateDiff("n", waitStartTime, Now) >= MAX_WAIT_MINUTES Then
            MsgBox "等待超时，未能获得主工作簿写入权限，请稍后重试", vbExclamation
            GoTo Cleanup
        End If
        Application.Wait Now + TimeValue("0:00:02")
    Loop
    
    ' 绑定目标工作表
    Set targetWs = targetWb.Worksheets("Day In")
    
    ' 直接赋值数据+格式，替代剪贴板复制，提升效率和稳定性
    Dim lastRow As Long
    lastRow = targetWs.Cells(targetWs.Rows.Count, "A").End(xlUp).Row + 1
    With sourceWs
        ' 赋值单元格值
        targetWs.Cells(lastRow, "A").Value = .Range("A7").Value
        targetWs.Cells(lastRow, "B").Value = .Range("B7").Value
        targetWs.Cells(lastRow, "C").Value = .Range("C7").Value
        targetWs.Cells(lastRow, "D").Value = .Range("D7").Value
        targetWs.Cells(lastRow, "Q").Value = .Range("Q7").Value
        ' 同步数字格式
        targetWs.Cells(lastRow, "A").NumberFormat = .Range("A7").NumberFormat
        targetWs.Cells(lastRow, "B").NumberFormat = .Range("B7").NumberFormat
        targetWs.Cells(lastRow, "C").NumberFormat = .Range("C7").NumberFormat
        targetWs.Cells(lastRow, "D").NumberFormat = .Range("D7").NumberFormat
        targetWs.Cells(lastRow, "Q").NumberFormat = .Range("Q7").NumberFormat
    End With
    
    ' 仅调整需要的列宽，替代全列AutoFit
    targetWs.Columns("A:D,Q").AutoFit
    
    ' 保存并关闭目标工作簿
    targetWb.Save
    targetWb.Close SaveChanges:=False
    
    MsgBox "数据提交成功", vbInformation
    
Cleanup:
    ' 释放对象资源
    Set targetWs = Nothing
    If Not targetWb Is Nothing Then
        On Error Resume Next
        targetWb.Close SaveChanges:=False
        On Error GoTo 0
    End If
    Set targetWb = Nothing
    Set sourceWs = Nothing
    
    ' 恢复源工作表保护
    If Not ThisWorkbook.Worksheets("Scheduled Ad").ProtectContents Then
        ThisWorkbook.Worksheets("Scheduled Ad").Protect PROTECT_PWD, UserInterfaceOnly:=True
    End If
    
    ' 恢复应用初始设置
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Sub

关键优化点说明 #

• 移除Activate/Select操作：直接通过对象引用工作表和单元格，彻底避免界面切换导致的运行时错误380，提升代码稳定性；
• 增加超时机制：设置最大等待时间，超时后自动退出循环，避免用户强制关闭导致的文件锁残留；
• 替代剪贴板复制：直接赋值单元格值和格式，无需依赖剪贴板，提升性能的同时避免与用户操作冲突；
• 完善错误捕获：确保无论是否出错，都能正确关闭文件、释放对象、恢复工作表保护和应用设置；
• 路径有效性检查：提前验证目标文件路径，避免无效路径导致的打开错误；
• 优化列宽调整：仅调整涉及数据的列，减少不必要的计算开销；
• 工作表保护优化：使用UserInterfaceOnly:=True，后续代码操作工作表无需重复解锁，提升效率。

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