如何优化VBA考勤追踪代码以提升大规模数据下的运行速度？

数据老陈

2026-8-14

如何优化大规模数据下的考勤追踪VBA代码以提升运行速度？

我编写了一段用于考勤追踪的VBA代码，逻辑是在Sheet3的B列查找指定名称对应的行，再逐单元格将考勤数据复制到Sheet1中。目前该逻辑已复用至12个月的考勤数据处理，但在大规模数据场景下运行速度较慢，希望了解提速方法或更高效的实现写法。

原代码：

Dim rng As Range
Dim Names As String
Dim rownumber As Long

Names = Sheet1.Cells(5, 4)

'Attendance Tracker

Set rng = Sheet3.Columns("B:B").Find(What:=Names, _
    LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    On Error Resume Next
    rownumber = rng.Row
    
    'jan - completed
    
    Sheet1.Cells(8, 9).Value = Sheet3.Cells(rownumber, 9).Value
    Sheet1.Cells(8, 10).Value = Sheet3.Cells(rownumber, 10).Value
    Sheet1.Cells(8, 11).Value = Sheet3.Cells(rownumber, 11).Value
    Sheet1.Cells(8, 12).Value = Sheet3.Cells(rownumber, 12).Value
    Sheet1.Cells(8, 13).Value = Sheet3.Cells(rownumber, 13).Value
    Sheet1.Cells(8, 14).Value = Sheet3.Cells(rownumber, 14).Value
    Sheet1.Cells(8, 15).Value = Sheet3.Cells(rownumber, 15).Value
    Sheet1.Cells(8, 16).Value = Sheet3.Cells(rownumber, 16).Value
    Sheet1.Cells(8, 17).Value = Sheet3.Cells(rownumber, 17).Value
    Sheet1.Cells(8, 18).Value = Sheet3.Cells(rownumber, 18).Value
    Sheet1.Cells(8, 19).Value = Sheet3.Cells(rownumber, 19).Value
    Sheet1.Cells(8, 20).Value = Sheet3.Cells(rownumber, 20).Value
    Sheet1.Cells(8, 21).Value = Sheet3.Cells(rownumber, 21).Value
    Sheet1.Cells(8, 22).Value = Sheet3.Cells(rownumber, 22).Value
    Sheet1.Cells(8, 23).Value = Sheet3.Cells(rownumber, 23).Value
  Sheet1.Cells(13, 9).Value = Sheet3.Cells(rownumber, 24).Value
  Sheet1.Cells(13, 10).Value = Sheet3.Cells(rownumber, 25).Value
  Sheet1.Cells(13, 11).Value = Sheet3.Cells(rownumber, 26).Value
  Sheet1.Cells(13, 12).Value = Sheet3.Cells(rownumber, 27).Value
  Sheet1.Cells(13, 13).Value = Sheet3.Cells(rownumber, 28).Value
  Sheet1.Cells(13, 14).Value = Sheet3.Cells(rownumber, 29).Value
  Sheet1.Cells(13, 15).Value = Sheet3.Cells(rownumber, 30).Value
  Sheet1.Cells(13, 16).Value = Sheet3.Cells(rownumber, 31).Value
  Sheet1.Cells(13, 17).Value = Sheet3.Cells(rownumber, 32).Value
  Sheet1.Cells(13, 18).Value = Sheet3.Cells(rownumber, 33).Value
  Sheet1.Cells(13, 19).Value = Sheet3.Cells(rownumber, 34).Value
  Sheet1.Cells(13, 20).Value = Sheet3.Cells(rownumber, 35).Value
  Sheet1.Cells(13, 21).Value = Sheet3.Cells(rownumber, 36).Value
  Sheet1.Cells(13, 22).Value = Sheet3.Cells(rownumber, 37).Value
  Sheet1.Cells(13, 23).Value = Sheet3.Cells(rownumber, 38).Value
  Sheet1.Cells(13, 24).Value = Sheet3.Cells(rownumber, 39).Value

优化方案与代码实现

1. 核心优化点

关闭屏幕刷新与事件触发：减少Excel界面交互的开销，这是VBA提速最基础的操作。
批量复制单元格区域：代替逐单元格赋值，大幅减少工作表读写次数。
缩小查找范围：避免整列查找，限定到实际有数据的行，提升查找效率。
严谨错误处理：避免因查找不到目标导致的后续代码报错。

2. 优化后的完整代码

Sub OptimizedAttendanceTracker()
    Dim rng As Range
    Dim Names As String
    Dim rownumber As Long
    Dim lastRow As Long
    
    ' 关闭屏幕刷新和事件触发，提升速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Names = Sheet1.Cells(5, 4).Value
    
    ' 缩小查找范围到Sheet3 B列实际有数据的行
    lastRow = Sheet3.Cells(Sheet3.Rows.Count, "B").End(xlUp).Row
    Set rng = Sheet3.Range("B1:B" & lastRow).Find(What:=Names, _
        LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    
    ' 检查是否找到目标名称
    If Not rng Is Nothing Then
        rownumber = rng.Row
        
        ' 批量复制第一组数据（Sheet3 I列到W列 → Sheet1 I8到W8）
        Sheet1.Range("I8:W8").Value = Sheet3.Range("I" & rownumber & ":W" & rownumber).Value
        ' 批量复制第二组数据（Sheet3 X列到AK列 → Sheet1 I13到X13）
        Sheet1.Range("I13:X13").Value = Sheet3.Range("X" & rownumber & ":AK" & rownumber).Value
    Else
        ' 未找到目标时的提示或处理逻辑
        MsgBox "未找到名称：" & Names, vbExclamation
    End If
    
    ' 恢复屏幕刷新和事件触发
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

3. 极致优化（超大规模数据场景）

如果数据量极大，可将Sheet3的目标行数据读取到数组中，再写入Sheet1，内存操作比直接读写工作表更快：

' 替换批量复制的代码段
Dim sourceArr As Variant
' 读取Sheet3目标行的I到AK列数据到数组
sourceArr = Sheet3.Range("I" & rownumber & ":AK" & rownumber).Value
' 将数组前15列（I-W）写入Sheet1 I8:W8
Sheet1.Range("I8:W8").Value = Application.Index(sourceArr, 1, Evaluate("ROW(1:15)"))
' 将数组后16列（X-AK）写入Sheet1 I13:X13
Sheet1.Range("I13:X13").Value = Application.Index(sourceArr, 1, Evaluate("ROW(16:31)"))

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