Excel VBA代码优化求助：共享工作簿同步对象释放报错

我开发了一款供3名用户同时使用的Excel数据录入窗体，用户端工作簿为「ENTRY APPLICATION」，录入数据存储在「NEWROUND」工作表，各用户分配独立数据范围（如用户1为A1:N2000）。需求为：将用户录入数据同步至共享文件夹中的「DATABASE.xlsm」的「FullArchive」工作表，再将共享库数据回写至用户端「ARCHIVE」工作表并按L列、A列排序。

最初使用Activate/Select操作实现数据复制，导致运行缓慢且易崩溃，希望通过Parent Object思路优化代码以提升效率。

参考建议修改代码后，在执行setwbkDATABASE = Nothing语句时出现错误，请求协助调整代码，解决报错并实现高效数据同步。

原代码 #

Sub DATA_BASE_ARCHIVE_FullArchive()

Application.ScreenUpdating = False

Windows("ENTRY APPLICATION.xlsm").Activate
Sheets("NEWROUND").Select
Range("A1:N2000").Select

Selection.Copy

Workbooks.Open filename:= _
    "\\2-2023\DATABASE.xlsm"
Windows("DATABASE.xlsm").Activate
Range("A2001").Select
Sheets("FullArchive").Paste
Cells.Select
Range("A2001").Activate
Application.CutCopyMode = False
Selection.Copy


Windows("ENTRY APPLICATION.xlsm").Activate
Sheets("ARCHIVE").Select

Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("ARCHIVE").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ARCHIVE").Sort.SortFields.ADD Key:=Columns("L:L") _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("ARCHIVE").Sort.SortFields.ADD Key:=Columns("A:A") _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("ARCHIVE").Sort
    .SetRange Columns("A:P")
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With


Windows("DATABASE.xlsm").Activate
ActiveWorkbook.Save
ActiveWindow.Close
Application.CutCopyMode = False
Windows("ENTRY APPLICATION.xlsm").Activate
Sheets("FORM").Select
End Sub

修改后代码 #

Sub DATA_BASE_ARCHIVE_FullArchive()

Dim rngNEWROUND As Excel.Range
Dim arrNEWROUND As Variant
Dim wbkDATABASE As Excel.Workbook
Dim rngDataTarget As Excel.Range
Dim rngDataSource As Excel.Range
Dim varData As Variant
Dim rngArchive As Excel.Range


Application.ScreenUpdating = False

Set rngNEWROUND = ThisWorkbook.Sheets("NEWROUND").Range("A1:N2000")

arrNEWROUND = ThisWorkbook.Sheets("NEWROUND").Range("A1:N2000")

Set wbkDATABASE = Workbooks.Open(filename:="E:\DELEGATION APPLICATION SAMPLE\2-2023\DATABASE.xlsm")

Set rngDataTarget = wbkDATABASE.Sheets("FullArchive").Range("A2001")

Set rngDataTarget = rngDataTarget.Resize(UBound(arrNEWROUND, 1), UBound(arrNEWROUND, 2))

rngDataTarget.Value = arrNEWROUND 

Set rngDataSource = rngDataTarget.Worksheet.Range("A2001")

varData = rngDataSource.Value 
wbkDATABASE.Save
wbkDATABASE.Close

setwbkDATABASE = Nothing '(and Im getting error here)

Set rngArchive = ThisWorkbook.Sheets("ARCHIVE").Range("A1") 'reference range

rngArchive.Value = varData   
   
   
ThisWorkbook.Worksheets("ARCHIVE").Sort.SortFields.Clear
ThisWorkbook.Worksheets("ARCHIVE").Sort.SortFields.ADD Key:=Columns("L:L"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ThisWorkbook.Worksheets("ARCHIVE").Sort.SortFields.ADD Key:=Columns("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

With ThisWorkbook.Worksheets("ARCHIVE").Sort
      .SetRange Columns("A:P")
      .Header = xlGuess
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
End With

Application.ScreenUpdating = True

Sheets("FORM").Select

End Sub

1. 修复Set wbkDATABASE = Nothing语法错误 #

报错原因是拼写错误：原代码中写的是setwbkDATABASE，正确写法是Set wbkDATABASE（Set和变量名之间必须有空格）。另外，工作簿关闭后该对象引用已失效，实际可以省略这句，VBA会自动回收内存，若要保留必须修正拼写。

2. 修正数据回写逻辑错误 #

修改后的代码仅读取了A2001单个单元格的值，而非FullArchive工作表的全部数据，完全不符合需求。需要改为读取数据库中所有已使用的归档数据，再回写到用户端。

3. 优化后的完整高效代码 #

以下代码彻底摒弃Activate/Select操作，改用对象直接引用，同时优化数据传输逻辑，大幅提升运行效率和稳定性：

Sub DATA_BASE_ARCHIVE_FullArchive()
    Dim wbkEntry As Workbook
    Dim wsNewRound As Worksheet
    Dim wsArchive As Worksheet
    Dim wbkDatabase As Workbook
    Dim wsFullArchive As Worksheet
    Dim sourceData As Variant
    Dim archiveData As Variant
    Dim targetStartCell As Range
    Dim lastRowDB As Long
    
    ' 禁用冗余功能提升效率
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    ' 绑定本地工作簿与工作表
    Set wbkEntry = ThisWorkbook
    Set wsNewRound = wbkEntry.Sheets("NEWROUND")
    Set wsArchive = wbkEntry.Sheets("ARCHIVE")
    
    ' 读取用户录入的有效数据（自动忽略空行）
    sourceData = wsNewRound.Range("A1:N" & wsNewRound.Cells(wsNewRound.Rows.Count, "A").End(xlUp).Row).Value
    
    ' 打开共享数据库
    Set wbkDatabase = Workbooks.Open(Filename:="E:\DELEGATION APPLICATION SAMPLE\2-2023\DATABASE.xlsm")
    Set wsFullArchive = wbkDatabase.Sheets("FullArchive")
    
    ' 动态获取数据库数据末尾行，避免固定位置导致覆盖
    lastRowDB = wsFullArchive.Cells(wsFullArchive.Rows.Count, "A").End(xlUp).Row + 1
    Set targetStartCell = wsFullArchive.Cells(lastRowDB, "A")
    
    ' 将用户数据写入数据库
    targetStartCell.Resize(UBound(sourceData, 1), UBound(sourceData, 2)).Value = sourceData
    
    ' 读取数据库全部归档数据
    archiveData = wsFullArchive.Range("A1:P" & wsFullArchive.Cells(wsFullArchive.Rows.Count, "A").End(xlUp).Row).Value
    
    ' 保存并关闭数据库
    wbkDatabase.Save
    wbkDatabase.Close
    
    ' 更新用户端归档表
    wsArchive.Cells.ClearContents
    wsArchive.Range("A1").Resize(UBound(archiveData, 1), UBound(archiveData, 2)).Value = archiveData
    
    ' 执行排序（修正引用范围，避免全局列引用错误）
    With wsArchive.Sort
        .SortFields.Clear
        .SortFields.Add Key:=wsArchive.Columns("L"), SortOn:=xlSortOnValues, Order:=xlAscending
        .SortFields.Add Key:=wsArchive.Columns("A"), SortOn:=xlSortOnValues, Order:=xlAscending
        .SetRange wsArchive.Columns("A:P")
        .Header = xlYes ' 明确表头，比xlGuess更可靠
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    
    ' 切换到FORM工作表
    wbkEntry.Sheets("FORM").Activate
End Sub

关键优化说明 #

• 移除Select/Activate：全程使用对象变量直接操作，消除界面刷新的性能开销
• 数组传输数据：将单元格数据读入数组再批量写入，比逐个单元格操作效率提升百倍以上
• 动态定位数据行：自动识别数据库数据末尾，避免固定行号导致的覆盖或遗漏问题
• 禁用冗余功能：临时关闭屏幕更新、事件和警告，进一步提升运行速度
• 修正排序引用：直接绑定工作表的列对象，避免全局列引用可能引发的错误

内容的提问来源于stack exchange，提问作者Funny Memo Ms