Excel VBA UUID跨表查找替换代码优化求助

问题背景 #

我有一个工作簿，主工作表job加载了JSON数据，包含6列UUID，共约1000行。需要从另外3个工作表（staff、client、category）交叉引用，将UUID替换为对应的值。目前代码仅处理4列，还有2列待处理，运行耗时约23秒。现有代码可正常运行但速度过慢，需要优化加速。

原代码（供参考）：

Sub UUID_Replace()

Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Ws3 As Worksheet
Dim Ws4 As Worksheet

Dim staffData As Variant
Dim clientData As Variant
Dim categoryData As Variant
Dim staffLastRow As Long
Dim clientLastRow As Long
Dim categoryLastRow As Long

Dim ColumnUUID As Range
Dim jobLastRow As Long
Dim jobValue As String
Dim joblastCol As Long
Dim jobCell As Range
Dim jobcolrange As Variant
    
Dim cellValue As String
Dim i As Long

Dim LookUpDict As Object

Dim startTime As Double
Dim stopTime As Double

startTime = Timer

Set Ws1 = ThisWorkbook.Worksheets("job")
Set Ws2 = ThisWorkbook.Worksheets("staff")
Set Ws3 = ThisWorkbook.Worksheets("category")
Set Ws4 = ThisWorkbook.Worksheets("client")

Set LookUpDict = CreateObject("Scripting.Dictionary")
   
joblastCol = Ws1.Cells(1, Ws1.Columns.Count).End(xlToLeft).Column
jobLastRow = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).row
jobcolrange = Ws1.Range(Ws1.Cells(1, 1), Ws1.Cells(jobLastRow, joblastCol)).value

staffLastRow = Ws2.Cells(Ws2.Rows.Count, "A").End(xlUp).row
staffData = Ws2.Range("A2:B" & staffLastRow).value

clientLastRow = Ws4.Cells(Ws4.Rows.Count, "A").End(xlUp).row
clientData = Ws4.Range("A2:C" & clientLastRow).value

categoryLastRow = Ws3.Cells(Ws3.Rows.Count, "A").End(xlUp).row
categoryData = Ws3.Range("A2:C" & categoryLastRow).value

For i = 1 To UBound(staffData)
    LookUpDict(staffData(i, 1)) = staffData(i, 2)
Next i

For i = 1 To joblastCol
    cellValue = jobcolrange(1, i)
    If InStr(1, cellValue, "actioned_by", vbTextCompare) > 0 Or _
    InStr(1, cellValue, "created_by", vbTextCompare) > 0 Then
        Set ColumnUUID = Ws1.Cells(1, i).EntireColumn
        For Each jobCell In ColumnUUID.Cells
            jobValue = jobCell.value
            If LookUpDict.Exists(jobValue) Then
                jobCell.value = LookUpDict(jobValue)
            End If
        Next jobCell
    End If
Next i

For i = 1 To UBound(clientData)
    LookUpDict(clientData(i, 1)) = clientData(i, 3)
Next i

For i = 1 To joblastCol
    cellValue = jobcolrange(1, i)
    If InStr(1, cellValue, "company_uuid", vbTextCompare) > 0 Then
        Set ColumnUUID = Ws1.Cells(1, i).EntireColumn
        For Each jobCell In ColumnUUID.Cells
            jobValue = jobCell.value
            If LookUpDict.Exists(jobValue) Then
                jobCell.value = LookUpDict(jobValue)
            End If
        Next jobCell
    End If
Next i

For i = 1 To UBound(categoryData)
    LookUpDict(categoryData(i, 1)) = categoryData(i, 3)
Next i

For i = 1 To joblastCol
    cellValue = jobcolrange(1, i)
    If InStr(1, cellValue, "category_uuid", vbTextCompare) > 0 Then
        Set ColumnUUID = Ws1.Cells(1, i).EntireColumn
        For Each jobCell In ColumnUUID.Cells
            jobValue = jobCell.value
            If LookUpDict.Exists(jobValue) Then
                jobCell.value = LookUpDict(jobValue)
            End If
        Next jobCell
    End If
Next i
stopTime = Timer
Debug.Print stopTime - startTime

    Set LookUpDict = Nothing
    
End Sub

优化思路 #

• 减少工作表交互：原代码逐个遍历单元格修改，这是速度慢的核心原因。改用数组一次性读取所有数据，在内存中完成替换后再写回工作表，大幅降低Excel对象模型的调用开销。
• 批量构建映射字典：提前为所有需要替换的UUID类型构建独立字典，避免重复清空/重建字典的操作。
• 关闭Excel后台操作：临时关闭屏幕更新、事件触发和公式计算，减少运行时的额外资源消耗。
• 精准遍历数据范围：只处理有数据的行，而非整列遍历，避免空单元格的无效循环。

优化后的代码 #

Sub Fast_UUID_Replace()
    Dim WsJob As Worksheet, WsStaff As Worksheet, WsClient As Worksheet, WsCategory As Worksheet
    Dim jobData As Variant, staffData As Variant, clientData As Variant, categoryData As Variant
    Dim dictStaff As Object, dictClient As Object, dictCategory As Object
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    Dim startTime As Double, stopTime As Double
    
    startTime = Timer
    
    ' 关闭Excel后台操作以提速
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    ' 初始化工作表对象
    Set WsJob = ThisWorkbook.Worksheets("job")
    Set WsStaff = ThisWorkbook.Worksheets("staff")
    Set WsClient = ThisWorkbook.Worksheets("client")
    Set WsCategory = ThisWorkbook.Worksheets("category")
    
    ' 初始化字典
    Set dictStaff = CreateObject("Scripting.Dictionary")
    Set dictClient = CreateObject("Scripting.Dictionary")
    Set dictCategory = CreateObject("Scripting.Dictionary")
    
    ' 读取所有数据到数组（内存操作远快于单元格操作）
    lastRow = WsJob.Cells(WsJob.Rows.Count, "A").End(xlUp).Row
    lastCol = WsJob.Cells(1, WsJob.Columns.Count).End(xlToLeft).Column
    jobData = WsJob.Range(WsJob.Cells(1, 1), WsJob.Cells(lastRow, lastCol)).Value
    
    ' 构建Staff映射字典
    staffData = WsStaff.Range("A2:B" & WsStaff.Cells(WsStaff.Rows.Count, "A").End(xlUp).Row).Value
    For i = LBound(staffData) To UBound(staffData)
        dictStaff(staffData(i, 1)) = staffData(i, 2)
    Next i
    
    ' 构建Client映射字典
    clientData = WsClient.Range("A2:C" & WsClient.Cells(WsClient.Rows.Count, "A").End(xlUp).Row).Value
    For i = LBound(clientData) To UBound(clientData)
        dictClient(clientData(i, 1)) = clientData(i, 3)
    Next i
    
    ' 构建Category映射字典
    categoryData = WsCategory.Range("A2:C" & WsCategory.Cells(WsCategory.Rows.Count, "A").End(xlUp).Row).Value
    For i = LBound(categoryData) To UBound(categoryData)
        dictCategory(categoryData(i, 1)) = categoryData(i, 3)
    Next i
    
    ' 在内存数组中完成所有替换
    For j = 1 To lastCol
        Select Case UCase(jobData(1, j))
            Case UCase("actioned_by"), UCase("created_by")
                ' 处理Staff相关列
                For i = 2 To lastRow ' 从第2行开始跳过表头
                    If dictStaff.Exists(jobData(i, j)) Then
                        jobData(i, j) = dictStaff(jobData(i, j))
                    End If
                Next i
            Case UCase("company_uuid")
                ' 处理Client相关列
                For i = 2 To lastRow
                    If dictClient.Exists(jobData(i, j)) Then
                        jobData(i, j) = dictClient(jobData(i, j))
                    End If
                Next i
            Case UCase("category_uuid")
                ' 处理Category相关列
                For i = 2 To lastRow
                    If dictCategory.Exists(jobData(i, j)) Then
                        jobData(i, j) = dictCategory(jobData(i, j))
                    End If
                Next i
            ' 添加剩余2列的处理逻辑，示例：
            ' Case UCase("other_uuid1"), UCase("other_uuid2")
            '     For i = 2 To lastRow
            '         If dictOther.Exists(jobData(i, j)) Then
            '             jobData(i, j) = dictOther(jobData(i, j))
            '         End If
            '     Next i
        End Select
    Next j
    
    ' 将修改后的数组一次性写回工作表
    WsJob.Range(WsJob.Cells(1, 1), WsJob.Cells(lastRow, lastCol)).Value = jobData
    
    ' 恢复Excel后台操作
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    
    stopTime = Timer
    Debug.Print "运行耗时：" & stopTime - startTime & "秒"
    
    ' 释放对象
    Set dictStaff = Nothing
    Set dictClient = Nothing
    Set dictCategory = Nothing
    Set WsJob = Nothing
    Set WsStaff = Nothing
    Set WsClient = Nothing
    Set WsCategory = Nothing
End Sub

优化效果说明 #

• 运行速度会提升数十倍（预计耗时在1秒以内），因为所有替换操作都在内存数组中完成，仅进行两次工作表读写（读入+写出）。
• 代码结构更清晰，新增列的处理只需在Select Case中添加对应分支即可。
• 保留了原有的字典查找逻辑，保证替换的准确性。

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