如何优化我的VBA宏以提升运行效率?
优化后的VBA宏代码
Option Explicit Sub Mass_Copy_Paste() ' 禁用Excel界面功能提升运行速度 Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Application.DisplayStatusBar = False Application.EnableEvents = False Dim ABC As Workbook Dim Matl As Workbook, Cost As Workbook, Name As Workbook Dim Source1 As Worksheet, Source2 As Worksheet, Source3 As Worksheet Dim Dest1 As Worksheet, Dest2 As Worksheet, Dest3 As Worksheet Dim Filename1 As String, Filename2 As String, Filename3 As String Dim lr1 As Long, lr2 As Long, lr3 As Long, lr4 As Long Dim lc1 As Long, lc2 As Long, lc3 As Long Dim ColumnNum1 As Long, ColumnNum2 As Long, ColumnNum3 As Long Set ABC = ThisWorkbook ' 修复原代码中Filename2重复赋值的错误 Filename1 = "C:\Users\Documents\Testfile1.xlsx" Filename2 = "C:\Users\Documents\Testfile2.xlsx" Filename3 = "C:\Users\Documents\Testfile3.xlsx" Set Matl = Workbooks.Open(Filename1) Set Cost = Workbooks.Open(Filename2) Set Name = Workbooks.Open(Filename3) Set Source1 = Matl.Sheets("Report") Set Source2 = Cost.Sheets("Report") Set Source3 = Name.Sheets("Report") ' 修复原代码中ABc的大小写错误 Set Dest1 = ABC.Sheets("Report1") Set Dest2 = ABC.Sheets("Report2") Set Dest3 = ABC.Sheets("Report3") ' 直接通过工作表对象获取列数/行数,无需激活 With Source1 ColumnNum1 = .Cells(11, .Columns.Count).End(xlToLeft).Column lc1 = ColumnNum1 ' 复用已计算的列数,避免重复计算 lr1 = .Cells(.Rows.Count, "A").End(xlUp).Row End With With Source2 ColumnNum2 = .Cells(6, .Columns.Count).End(xlToLeft).Column lc2 = ColumnNum2 lr2 = .Cells(.Rows.Count, "A").End(xlUp).Row End With With Source3 ColumnNum3 = .Cells(6, .Columns.Count).End(xlToLeft).Column lc3 = ColumnNum3 lr3 = .Cells(.Rows.Count, "A").End(xlUp).Row End With ' 直接清理目标工作表内容,无需激活 With Dest1 .Range(.Cells(2, "A"), .Cells(.Rows.Count, ColumnNum1).End(xlUp)).ClearContents End With With Dest2 .Range(.Cells(2, "A"), .Cells(.Rows.Count, ColumnNum1).End(xlUp)).ClearContents End With With Dest3 .Range(.Cells(2, "A"), .Cells(.Rows.Count, ColumnNum1).End(xlUp)).ClearContents End With ' 替换Copy/PasteSpecial为直接赋值,大幅提升速度 ' 从Source1复制到Dest1 Dest1.Range("A2").Resize(lr1 - 11, lc1).Value = Source1.Range("A12").Resize(lr1 - 11, lc1).Value ' 从Source2复制到Dest1(保持原代码覆盖A2开始区域的逻辑) Dest1.Range("A2").Resize(lr2 - 6, lc2).Value = Source2.Range("A7").Resize(lr2 - 6, lc2).Value ' 从Source3复制到Dest1 Dest1.Range("A2").Resize(lr3 - 6, lc3).Value = Source3.Range("A7").Resize(lr3 - 6, lc3).Value ' 合并Autofill操作,减少重复代码调用 With Dest1 lr4 = .Cells(.Rows.Count, "A").End(xlUp).Row ' 一次性填充从BW到CI的连续列 .Range("BW2:CI2").AutoFill Destination:=.Range("BW2:CI" & lr4), Type:=xlFillDefault End With With Dest2 lr4 = .Cells(.Rows.Count, "A").End(xlUp).Row ' 填充分散的AZ、BA、BC-BG列 .Range("AZ2,BA2,BC2:BG2").AutoFill Destination:=.Range("AZ2:BG" & lr4), Type:=xlFillDefault End With With Dest3 lr4 = .Cells(.Rows.Count, "A").End(xlUp).Row ' 一次性填充从CD到CL的连续列 .Range("CD2:CL2").AutoFill Destination:=.Range("CD2:CL" & lr4), Type:=xlFillDefault End With ABC.RefreshAll Application.CalculateFullRebuild ' 恢复Excel界面功能 Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.DisplayStatusBar = True Application.EnableEvents = True ' 关闭源工作簿(可选,可根据需求设置是否保存) Matl.Close SaveChanges:=False Cost.Close SaveChanges:=False Name.Close SaveChanges:=False End Sub
关键优化说明
1. 彻底移除Activate操作
频繁激活工作表是拖慢宏运行的核心原因之一,优化后直接通过预先定义的工作表对象(如Source1、Dest1)操作单元格,所有单元格引用前添加.前缀明确归属,全程无需切换激活任何工作表。
2. 用直接赋值替代复制粘贴
复制粘贴依赖剪贴板,速度慢且易引发意外。直接通过.Value属性传递数据是最快的方式,效率比复制粘贴提升显著。
3. 合并重复的自动填充操作
原代码逐列执行Autofill,优化后合并连续或可批量处理的列,减少方法调用次数,进一步提升运行效率。
4. 修复错误与清理冗余
- 修正原代码中
Filename2重复赋值的错误 - 修正
ABc的大小写拼写错误 - 移除未使用的全局变量,将变量声明移至过程内部,避免全局变量污染
- 复用已计算的列数值,避免重复计算
- 新增源工作簿关闭逻辑(可选,可根据需求调整是否保存)
5. 保留基础效率优化
原代码中禁用界面更新、手动计算的设置是正确的,优化后保留该逻辑,并在宏运行结束后恢复Excel默认设置,确保后续操作正常。
内容的提问来源于stack exchange,提问作者Mcduck
相关产品推荐
相关产品推荐

