共享Excel工作簿后宏首次正常、后续运行极慢问题求助

问题概述 #

• 非共享状态下宏运行完全正常；工作簿共享后，首次运行宏无异常，第二次运行耗时极久，关闭并重新打开工作簿后恢复正常
• 已尝试：清除剪贴板（含宏清除方式）、更换数据复制方式（Value=Value、数组）、基础操作优化，均未改善
• 卡顿表现：状态栏显示“填充单元格”且进度缓慢，复制1000行或10000行数据均出现该问题

原代码 #

Sub Macro4()
    
    Dim MyDate As String
    Dim MyTime As String
    Dim MyFile As String
    Dim MyCriteria As String
    Dim WFile As String
    Dim CopyFile As String
    Dim CopyFile1 As String
    Dim BackupCopy As String
    Dim dt As Date
    Dim dt2 As Date
    
    Dim FSO As Object
    
    Set wb = ThisWorkbook
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    MyDate = Format(Now, "DD.MM.YY")
    MyTime = Format(Now, "HH.MM.SS")
    MyFile = ThisWorkbook.Name
    
    MyCriteria = ThisWorkbook.Sheets("Settings").Range("F1").Value
    WFile = "file_export.csv"
    CopyFile = "file.csv"
    CopyFile1 = "copy"
    BackupCopy = "file_backup.csv"
    
    'dt = Format(wb.Sheets("Dotcom").Range("F1"), "dd/mm/yyyy")
    dt = wb.Sheets("Dotcom").Range("F1")
    dt2 = dt - 1
    
    'Now2 = CDate(Now() - 1) 'formatting the date using the CDate function
    'Now2 = Format(Now2, "MM/DD/YYYY") 'formatting the date by dropping the hour
    
    'dt2 = CDate(dt2) 'formatting the date using the CDate function
    'dt2 = Format(dt2, "MM/DD/YYYY") 'formatting the date by dropping the hour
    
    Application.EnableEvents = False
    Application.Calculation = xlManual
    For N = 1 To 9
        With wb.Sheets("Day" & N)
            .UsedRange.Columns("A:G").Clear
        End With
    Next
    
    Application.Calculation = xlAutomatic
    Application.EnableEvents = True
    Application.CutCopyMode = False
        
    Workbooks.Open ("c:\scripts\" & CopyFile)
    
    With Workbooks(CopyFile).Sheets(CopyFile1)
        With .UsedRange
            .AutoFilter Field:=1, Criteria1:"<>" & MyCriteria
            .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .AutoFilter
        End With
        .Range("A1").CurrentRegion.Copy
    End With
    
    For N = 1 To 9
        With wb.Sheets("Day" & N)
            .Range("A1").PasteSpecial Paste:=xlPasteAll
        End With
    Next
        
    Application.CutCopyMode = False
    Workbooks(CopyFile).Close savechanges:=False
    
    For N = 1 To 9
        With wb.Sheets("Day" & N)
            With .UsedRange.Columns("A:G")
                .AutoFilter Field:=5, Criteria1:"<" & CLng(dt2), _
                    Operator:=xlOr, Criteria2:">=" & CLng(dt2) + 1
                .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
                .AutoFilter
            End With
    
            dt2 = dt2 + 1
        End With
    Next
    
End Sub

核心问题分析 #

共享工作簿会启用冲突日志、修订跟踪等后台机制，宏运行时这些进程会产生额外开销；原代码的以下设计进一步放大了卡顿：

1. 频繁切换Calculation模式，共享环境下计算引擎的状态切换成本远高于普通工作簿
2. 重复复制粘贴数据到9个工作表，共享工作簿的单元格写入锁机制会被多次触发，导致等待延迟
3. UsedRange和CurrentRegion在共享模式下会触发额外的范围校验，拖慢操作速度
4. 未禁用屏幕刷新，共享环境下UI同步会消耗大量系统资源

优化后的代码 #

Sub OptimizedMacro()
    Dim MyCriteria As String
    Dim CopyFile As String
    Dim CopyFile1 As String
    Dim dt As Date
    Dim dt2 As Date
    Dim sourceWS As Worksheet
    Dim sourceData As Variant
    Dim targetWS As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim n As Long
    
    ' 锁定全局环境，减少共享工作簿交互开销
    With Application
        .EnableEvents = False
        .Calculation = xlManual
        .ScreenUpdating = False
        .CutCopyMode = False
    End With
    
    Set wb = ThisWorkbook
    MyCriteria = wb.Sheets("Settings").Range("F1").Value
    CopyFile = "file.csv"
    CopyFile1 = "copy"
    
    dt = wb.Sheets("Dotcom").Range("F1").Value
    dt2 = dt - 1
    
    ' 批量清空目标工作表，减少单独操作次数
    For n = 1 To 9
        Set targetWS = wb.Sheets("Day" & n)
        targetWS.Range("A:G").ClearContents
    Next n
    
    ' 读取并处理源数据
    Workbooks.Open ("c:\scripts\" & CopyFile)
    Set sourceWS = Workbooks(CopyFile).Sheets(CopyFile1)
    
    ' 过滤并删除不符合条件的行
    With sourceWS.UsedRange
        .AutoFilter Field:=1, Criteria1:="<>" & MyCriteria
        On Error Resume Next ' 处理无匹配行的情况，避免宏中断
        .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        On Error GoTo 0
        .AutoFilter
    End With
    
    ' 将源数据存入数组，彻底绕过剪贴板和共享锁机制
    lastRow = sourceWS.Cells(sourceWS.Rows.Count, "A").End(xlUp).Row
    lastCol = sourceWS.Cells(1, sourceWS.Columns.Count).End(xlToLeft).Column
    sourceData = sourceWS.Range(sourceWS.Cells(1, 1), sourceWS.Cells(lastRow, lastCol)).Value
    
    Workbooks(CopyFile).Close savechanges:=False
    
    ' 批量写入数据并处理日期过滤
    dt2 = dt - 1
    For n = 1 To 9
        Set targetWS = wb.Sheets("Day" & n)
        ' 数组批量写入，比复制粘贴快数倍
        targetWS.Range("A1").Resize(UBound(sourceData, 1), UBound(sourceData, 2)).Value = sourceData
        
        ' 过滤目标日期范围并删除无关行
        With targetWS.Range("A1").CurrentRegion.Columns("A:G")
            .AutoFilter Field:=5, Criteria1:"<" & CLng(dt2), _
                Operator:=xlOr, Criteria2:">=" & CLng(dt2) + 1
            On Error Resume Next
            .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            On Error GoTo 0
            .AutoFilter
        End With
        dt2 = dt2 + 1
    Next n
    
    ' 恢复全局环境设置
    With Application
        .EnableEvents = True
        .Calculation = xlAutomatic
        .ScreenUpdating = True
    End With
End Sub

关键优化点 #

• 禁用屏幕刷新：添加ScreenUpdating = False，避免共享工作簿的UI同步带来的额外消耗
• 数组替代复制粘贴：将源数据存入数组后批量写入目标工作表，彻底绕过剪贴板和共享模式下的单元格写入锁
• 减少模式切换：全程保持手动计算，直到宏结束再恢复，避免多次切换计算模式的额外开销
• 错误处理：添加On Error Resume Next处理无匹配行的情况，防止宏意外中断
• 批量操作：清空工作表时直接操作整列，减少UsedRange的调用次数，降低范围校验成本

额外建议 #

1. 关闭共享工作簿的修订跟踪：依次点击「文件」→「信息」→「保护工作簿」→「共享工作簿」，取消勾选“允许修订”
2. 定期清理冲突日志：依次点击「文件」→「信息」→「检查问题」→「检查兼容性」，选择“冲突日志”进行清理
3. 避免频繁使用UsedRange：改用End(xlUp)/End(xlToLeft)精准定位数据范围，减少不必要的范围校验

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