Excel工时库更新VBA代码优化求助：大数据集运行过慢

我需要维护一个存储多年数据的Excel工时库，共45000行，数据结构如下。每月要提取当前月T及前三个月t-1、t-2、t-3的工时数据，操作流程是：先从库中减去上月对应数据，再加载新数据更新工时；同时将新出现的Combination追加到库末尾。我已编写实现功能的VBA代码，但因库规模大且每月处理85000行数据，代码运行速度极慢，寻求优化方案。

数据结构表 #

现有VBA代码 #

Sub UpdateHours()
Dim data1 As Variant, data2 As Variant
Dim StartTime As Double
Dim MinutesElapsed As String

Application.ScreenUpdating = False

StartTime = timer

lastRow = Worksheets("TimeReg_Billable").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
lastRowTRB = Worksheets("TimeRegistrations_Billable").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row

data1 = Worksheets("TimeReg_Billable").Range("A2:I" & lastRow).Value
data2 = Worksheets("TimeRegistrations_Billable").Range("A2:W" & lastRowTRB).Value

For i = 1 To lastRow
If i > UBound(data1, 1) Then Exit For
    For k = 1 To lastRowTRB
        If k > UBound(data2, 1) Then Exit For
        If data1(i, 1) = data2(k, 23) Then
            data1(i, 2) = data1(i, 2) - data2(k, 15)

        End If
    Next k
Next i

Worksheets("TimeReg_Billable").Range("A2:I" & lastRow).Value = data1


'Load data
'Workbooks.Open "C:\Users\jabha\Desktop\Projekt ark\INSERTNAMEHERE.xls"

'Workbooks("INSERTNAMEHERE.xls").Worksheets("EGTimeSearchControllingResults").Range("A:AA").Copy _
    Workbooks("Projekt.xlsm").Worksheets("TimeRegistrations_Billable").Range("A1")

'Workbooks("INSERTNAMEHERE.xls").Close SaveChages = False


'Insert the new numbers

lastRow = Worksheets("TimeReg_Billable").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
lastRowTRB = Worksheets("TimeRegistrations_Billable").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row

myarray = Worksheets("TimeReg_Billable").Range("A2:A" & lastRow)

data1 = Worksheets("TimeReg_Billable").Range("A2:I" & lastRowTRB).Value
data2 = Worksheets("TimeRegistrations_Billable").Range("A2:W" & lastRowTRB).Value

i = 1
Do While i <= lastRow
If i > UBound(data1, 1) Then Exit Do
    k = 1
    Do While k <= lastRowTRB
        If k > UBound(data2, 1) Then Exit Do
        If data1(i, 1) = data2(k, 23) Then
            data1(i, 2) = data1(i, 2) + data2(k, 15)
        End If
        If Not data1(i, 1) = data2(k, 23) Then
            Teststring = Application.Match(data2(k, 23), myarray, 0)
            If IsError(Teststring) Then
                data1(lastRow, 1) = data2(k, 23)
                data1(lastRow, 3) = data2(k, 11)
                data1(lastRow, 4) = data2(k, 16)
                data1(lastRow, 5) = data2(k, 17)
                data1(lastRow, 6) = data2(k, 20)
                data1(lastRow, 7) = data2(k, 21)
                data1(lastRow, 8) = data2(k, 22)
                data1(lastRow, 9) = data2(k, 7)
                lastRow = lastRow + 1
                myarray = Application.Index(data1, 0, 1)
            End If
        End If
    k = k + 1
    Loop
    If data1(i, 9) = "#N/A" Then
        data1(i, 9) = ""
    End If
i = i + 1
Loop

Worksheets("TimeReg_Billable").Range("A2:I" & lastRowTRB).Value = data1

MinutesElapsed = Format((timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "This code ran succesfully in " & MinutesElapsed & " minutes", vbInformation

End Sub

优化方案 #

1. 用字典替换嵌套循环，降低时间复杂度 #

原代码双层嵌套循环的时间复杂度是O(nm)，4500085000的量级会导致运行极慢。改用Scripting.Dictionary存储Combination与行索引的映射，将匹配操作降为O(1)：

Dim comboDict As Object
Set comboDict = CreateObject("Scripting.Dictionary")

' 初始化字典：Combination -> 库数据中的行索引
For i = 1 To UBound(data1, 1)
    If Not comboDict.Exists(data1(i, 1)) Then
        comboDict(data1(i, 1)) = i
    End If
Next i

' 批量减去上月数据
For k = 1 To UBound(data2, 1)
    currentCombo = data2(k, 23)
    If comboDict.Exists(currentCombo) Then
        data1(comboDict(currentCombo), 2) = data1(comboDict(currentCombo), 2) - data2(k, 15)
    End If
Next k

2. 减少数组重定义与工作表交互 #

• 原代码每次追加新Combination时都重新生成myarray，建议先收集所有新增Combination，最后一次性扩展数组并写入数据
• 只在所有数据处理完成后，一次性将结果写入工作表，减少IO开销

3. 关闭更多Excel后台功能 #

除了ScreenUpdating = False，额外关闭以下选项可大幅提速：

Application.EnableEvents = False ' 禁用事件触发
Application.Calculation = xlCalculationManual ' 手动计算
Application.DisplayAlerts = False ' 禁用警告弹窗

注意在代码结束前恢复默认设置：

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True

4. 优化新增Combination的检测逻辑 #

原代码循环中频繁调用Application.Match效率低下，改用双字典对比：

Dim newComboDict As Object
Set newComboDict = CreateObject("Scripting.Dictionary")

' 收集新数据中的所有Combination
For k = 1 To UBound(data2, 1)
    currentCombo = data2(k, 23)
    If Not newComboDict.Exists(currentCombo) Then
        newComboDict(currentCombo) = k ' 存储新数据中的行索引
    End If
Next k

' 批量处理新增Combination
For Each combo In newComboDict.Keys
    If Not comboDict.Exists(combo) Then
        lastRow = lastRow + 1
        ' 扩展库数据数组
        ReDim Preserve data1(1 To lastRow, 1 To UBound(data1, 2))
        ' 填充新行数据
        data1(lastRow, 1) = combo
        data1(lastRow, 3) = data2(newComboDict(combo), 11)
        data1(lastRow, 4) = data2(newComboDict(combo), 16)
        data1(lastRow, 5) = data2(newComboDict(combo), 17)
        data1(lastRow, 6) = data2(newComboDict(combo), 20)
        data1(lastRow, 7) = data2(newComboDict(combo), 21)
        data1(lastRow, 8) = data2(newComboDict(combo), 22)
        data1(lastRow, 9) = data2(newComboDict(combo), 7)
        ' 更新字典
        comboDict(combo) = lastRow
    End If
Next combo

5. 修正数组赋值错误 #

原代码中data1 = Worksheets("TimeReg_Billable").Range("A2:I" & lastRowTRB).Value存在逻辑错误，lastRowTRB是新数据行数，应使用库数据的lastRow赋值，避免创建过大的空数组。

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