VBA自定义VLookupCC函数运行缓慢且颜色同步异常求助

原代码的核心问题 #

• ActiveCell指向错误：自动填充时函数批量计算，ActiveCell始终是触发填充的初始单元格，而非正在计算的目标单元格，导致颜色仅能应用到第一个单元格，其余需手动回车才生效。
• 低效的循环查找：手动遍历每行数据的效率远低于Excel内置的Application.VLookup，数据量大时卡顿明显。
• Evaluate调用的额外开销：每次通过Evaluate执行宏都会产生额外性能消耗，频繁调用会大幅拖慢速度。
• UDF的固有限制：Excel用户自定义函数（UDF）原生不允许修改单元格格式，原方法用Evaluate绕开限制的方式不稳定，不符合规范。

方案一：工作表事件+内置VLookup（推荐） #

利用工作表Calculate事件，在每次计算完成后自动同步格式，效率与稳定性拉满。

1. 右键目标工作表标签 → 选择「查看代码」
2. 粘贴以下代码：

Private Sub Worksheet_Calculate()
    Dim rng As Range
    Dim cell As Range
    Dim lookupVal As Variant
    Dim lookupRange As Range
    Dim colIndex As Long
    Dim sourceCell As Range
    
    ' 定位所有带公式的单元格
    On Error Resume Next
    Set rng = Me.Cells.SpecialCells(xlCellTypeFormulas)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub
    
    ' 关闭屏幕更新与事件触发，提升速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    For Each cell In rng
        ' 只处理包含VLOOKUP的公式
        If InStr(1, cell.Formula, "VLOOKUP", vbTextCompare) > 0 Then
            ' 解析VLOOKUP参数（适配标准格式：=VLOOKUP(查找值, 查找范围, 列索引, 匹配方式)）
            Dim formulaParts As Variant
            formulaParts = Split(Mid(cell.Formula, 10), ",")
            lookupVal = cell.Evaluate(formulaParts(0))
            Set lookupRange = Me.Parent.Range(Trim(formulaParts(1)))
            colIndex = CLng(Trim(Split(formulaParts(2), ")")(0)))
            
            ' 查找匹配的源单元格
            Set sourceCell = lookupRange.Find(What:=lookupVal, LookIn:=xlValues, LookAt:=xlWhole)
            If Not sourceCell Is Nothing Then
                Set sourceCell = sourceCell.Offset(0, colIndex - 1)
                cell.Interior.ColorIndex = sourceCell.Interior.ColorIndex
            Else
                cell.Interior.ColorIndex = xlColorIndexNone
            End If
        End If
    Next cell
    
    ' 恢复系统设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

说明：

• 每次工作表计算完成后，自动扫描所有VLOOKUP公式单元格，同步对应源单元格的填充色。
• 自动填充后无需手动回车，公式计算完成即同步格式。
• 内置VLOOKUP+批量处理的组合，速度比原UDF提升数倍。

方案二：改进版UDF（仅当必须用自定义函数时使用） #

通过Application.Caller解决ActiveCell指向问题，用内置VLOOKUP替代手动循环，去掉Evaluate提升效率，但需注意UDF修改格式的兼容性风险。

替换原代码为：

' 注意：Excel官方不允许UDF修改单元格格式，此方法可能在部分场景下失效
Public Function VLookupCC(lookup_value As Variant, lookup_range As Range, column_index As Long) As Variant
    Dim sourceCell As Range
    Dim lookupRes As Variant
    
    ' 校验列索引合法性
    If column_index < 1 Or column_index > lookup_range.Columns.Count Then
        VLookupCC = CVErr(xlErrValue)
        Exit Function
    End If
    
    ' 用内置VLOOKUP快速查找
    lookupRes = Application.VLookup(lookup_value, lookup_range, column_index, False)
    
    If Not IsError(lookupRes) Then
        VLookupCC = lookupRes
        ' 定位匹配的源单元格
        Set sourceCell = lookup_range.Find(What:=lookup_value, LookIn:=xlValues, LookAt:=xlWhole).Offset(0, column_index - 1)
        ' 用Application.Caller获取当前计算的单元格
        ChangeColor Application.Caller, sourceCell.Interior.ColorIndex
    Else
        VLookupCC = CVErr(xlErrNA)
        ChangeColor Application.Caller, xlColorIndexNone
    End If
End Function

' 修改参数类型为Range，直接操作目标单元格
Sub ChangeColor(targetCell As Range, colorindex_result As Integer)
    targetCell.Interior.ColorIndex = colorindex_result
End Sub

说明：

• Application.Caller可准确获取当前执行函数的单元格，解决自动填充时的指向错误。
• 内置VLOOKUP替代手动循环，大幅提升查找速度。
• 去掉Evaluate直接调用子过程，减少性能开销。

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