查找另一工作表中匹配值的列号（优化VBA性能及自动更新）

问题背景 #

工作簿包含两个工作表：

• Billings：每日由多人新增行数据，「City Name」列的城市名称输入格式不统一（例如New York可能被输入为NYC、NY等）
• Database Names：作为城市名称查找库，第2行存储城市的标准拼写，下方行记录该城市所有出现过的变体拼写

需求 #

1. 通过公式或VBA实现：将Billings中数千条城市记录与Database Names中的变体（含标准拼写）匹配，返回匹配值所在的列号，供后续OFFSET公式调用
2. 支持编辑Billings的「City Name」列后自动更新匹配结果
3. 优化现有VBA代码（当前运行耗时5-8分钟，数据量越大耗时越长）

现有VBA代码及问题 #

现有代码采用双重循环遍历单元格，频繁的工作表IO操作导致效率极低，且UsedRange可能包含空单元格造成无效遍历：

With Sheets("Billings").Range("b1")
    Set columnLocationList = Range(.Offset(1, 0), .End(xlDown))
End With

For Each columnLocations In columnLocationList
    For Each locations In Sheets("Database Names").UsedRange
        If columnLocations = locations Then
            columnLocations.Offset(0, 1).Value = locations.Column
            GoTo nextBill
        End If
    Next locations
nextBill:
Next columnLocations

优化方案 #

方案一：公式法（自动更新，无需VBA） #

在Billings的「Column Number」列（假设为C列，第2行开始）输入以下公式，支持编辑「City Name」后自动更新：

=XLOOKUP(B2, TRANSPOSE('Database Names'!A2:ZZ100), TRANSPOSE(COLUMN('Database Names'!A2:ZZ100)), "")

说明：

• TRANSPOSE('Database Names'!A2:ZZ100)：将Database Names中第2行到第100行的所有变体（含标准拼写）区域转成一维数组
• XLOOKUP：查找B2的城市名称，返回对应的列号；无匹配时返回空值
• 可根据实际数据范围调整A2:ZZ100为更大或更小的区域

方案二：优化后的VBA代码（高效批量处理+自动更新） #

通过内存数组+字典映射大幅提升效率，同时添加工作表事件实现自动更新：

核心匹配代码

Sub MatchCityColumns()
    Dim wsBill As Worksheet, wsDB As Worksheet
    Dim cityData As Variant, dbData As Variant
    Dim cityDict As Object
    Dim i As Long, j As Long, lastRow As Long, lastCol As Long
    
    ' 初始化工作表对象
    Set wsBill = ThisWorkbook.Sheets("Billings")
    Set wsDB = ThisWorkbook.Sheets("Database Names")
    Set cityDict = CreateObject("Scripting.Dictionary")
    
    ' 关闭屏幕更新和事件，减少资源占用
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    On Error GoTo Cleanup ' 异常处理，确保恢复系统设置
    
    ' 读取Database Names的核心数据到内存数组
    lastCol = wsDB.Cells(2, wsDB.Columns.Count).End(xlToLeft).Column
    dbData = wsDB.Range(wsDB.Cells(2, 1), wsDB.Cells(wsDB.Rows.Count, lastCol)).Value
    
    ' 构建【城市名称-列号】映射字典（包含标准拼写和所有变体）
    For j = 1 To UBound(dbData, 2)
        ' 加入标准拼写（数组第1行=工作表第2行）
        If dbData(1, j) <> "" Then
            cityDict(dbData(1, j)) = j
        End If
        ' 加入所有变体（数组第2行及以下=工作表第3行及以下）
        For i = 2 To UBound(dbData, 1)
            If dbData(i, j) <> "" Then
                cityDict(dbData(i, j)) = j
            End If
        Next i
    Next j
    
    ' 读取Billings的City Name和Column Number列数据到内存数组
    lastRow = wsBill.Cells(wsBill.Rows.Count, "B").End(xlUp).Row
    cityData = wsBill.Range(wsBill.Cells(2, "B"), wsBill.Cells(lastRow, "C")).Value
    
    ' 内存中完成匹配，写入结果
    For i = 1 To UBound(cityData, 1)
        cityData(i, 2) = IIf(cityDict.Exists(cityData(i, 1)), cityDict(cityData(i, 1)), "")
    Next i
    
    ' 将结果批量写回工作表
    wsBill.Range(wsBill.Cells(2, "B"), wsBill.Cells(lastRow, "C")).Value = cityData

Cleanup:
    ' 恢复系统设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    ' 释放对象
    Set cityDict = Nothing
    Set wsBill = Nothing
    Set wsDB = Nothing
End Sub

自动更新事件代码

打开Billings工作表的代码窗口，粘贴以下代码，实现编辑「City Name」列后自动触发匹配：

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 仅当修改B列（City Name）时执行匹配
    If Not Intersect(Target, Me.Columns("B")) Is Nothing Then
        MatchCityColumns
    End If
End Sub

优化说明

1. 字典映射：将所有城市名称（标准+变体）与列号的映射存储在字典中，查找效率从O(n)提升至O(1)
2. 内存数组：将工作表数据一次性读入内存数组，避免频繁的单元格读写操作，大幅减少IO耗时
3. 系统设置优化：关闭屏幕更新和事件，减少运行时的资源消耗
4. 自动触发：通过Worksheet_Change事件实现编辑后自动更新

示例验证 #

根据提供的示例数据：

• Billings表中B2为NYC，匹配到Database Names表的New York列（工作表第3列），C2返回3
• B3为LAX，匹配到Los Angeles列（工作表第2列），C3返回2，与预期结果一致

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