Excel VBA：基于单列输入返回对应列值，Select Case代码能否优化？

原代码存在的问题 #

1. 触发过于频繁：Worksheet_SelectionChange事件会在每次选区变动时触发，哪怕操作和I、K列完全无关，会造成不必要的资源消耗
2. 遍历效率低下：每次都从头遍历整个I列，没有区分已处理或未变动的单元格
3. 匹配关系扩展性差：硬编码的Select Case新增/修改匹配规则时需要修改代码逻辑，维护成本高

优化后的代码 #

Option Explicit

' 提前定义部门-负责人匹配字典，方便后续维护
Private Function GetResponsibleDict() As Scripting.Dictionary
    Set GetResponsibleDict = New Scripting.Dictionary
    ' 注意：字典Key默认不区分大小写，如需区分可加参数 Compare:=vbBinaryCompare
    GetResponsibleDict("Marketing") = "John Smith"
    GetResponsibleDict("Desktop Support") = "Jane Doe"
End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim lastRow As Long
    Dim targetRange As Range
    Dim dataArr As Variant
    Dim i As Long
    Dim responsibleDict As Scripting.Dictionary
    
    ' 1. 限制触发范围：仅当选区涉及I列或K列时才执行
    If Intersect(Target, Me.Range("I:I,K:K")) Is Nothing Then Exit Sub
    
    ' 2. 初始化匹配字典
    Set responsibleDict = GetResponsibleDict()
    
    ' 3. 获取I列有效数据范围，避免遍历空行
    lastRow = Me.Cells(Me.Rows.Count, "I").End(xlUp).Row
    If lastRow < 2 Then Exit Sub ' 无有效数据时直接退出
    Set targetRange = Me.Range("I2:K" & lastRow)
    
    ' 4. 批量读取数据到数组，减少Excel对象交互（提升效率核心）
    dataArr = targetRange.Value
    
    ' 5. 数组内批量处理逻辑
    For i = LBound(dataArr, 1) To UBound(dataArr, 1)
        If responsibleDict.Exists(dataArr(i, 1)) Then
            dataArr(i, 3) = responsibleDict(dataArr(i, 1))
        Else
            dataArr(i, 3) = "Not Defined"
        End If
    Next i
    
    ' 6. 将处理结果写回工作表
    targetRange.Value = dataArr
End Sub

关键优化点说明 #

• 事件触发限制：通过Intersect判断选区是否涉及目标列，避免无意义的执行
• 字典替代Select Case：把匹配关系独立成函数，新增规则只需在字典里添加键值对，无需修改核心逻辑
• 数组批量处理：把单元格数据读到内存数组中处理，大幅减少VBA和Excel界面的交互次数，这是提升VBA运行速度的核心技巧
• 边界判断：提前判断是否有有效数据，避免无效循环

额外注意事项 #

• 使用Scripting.Dictionary需要先引用「Microsoft Scripting Runtime」，或者改用后期绑定（把New Scripting.Dictionary换成CreateObject("Scripting.Dictionary")）
• 如果只需要在I列单元格修改时触发，建议改用Worksheet_Change事件，比SelectionChange更精准，避免误触发

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