如何通过宏重组数据以支持普通VLOOKUP跨多列查询？

需求背景 #

我有一个约60万行的大型.csv文件，包含不同账户，部分账户对应多个联系人及邮箱。同一账户的不同联系人邮箱分散在不同行，希望将数据转换为「同一账户一行、多列依次存放不同联系人+邮箱」的格式，方便后续使用普通VLOOKUP。之前尝试辅助列（公式：=A2&COUNTIF($A$2:$A2,A2)）和数组公式（=IFNA(VLOOKUP($E2&COLUMNS($F$1:F1),$B$2:$C$14,2,0),"")），但因文件过大，拆分处理仍会崩溃，需要用宏实现需求。

VBA宏代码 #

Sub MergeAccountContacts()
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim lastRow As Long, i As Long, colIndex As Integer
    Dim accountDict As Object
    Dim contactList As Collection
    Dim arrData, arrOutput
    Dim key As Variant, item As Variant
    
    ' 关闭屏幕更新与事件，大幅提升大文件处理速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 指定源数据工作表（默认当前活动表）
    Set wsSource = ActiveSheet
    ' 创建新工作表存放合并结果
    Set wsDest = ThisWorkbook.Sheets.Add(After:=wsSource)
    wsDest.Name = "合并结果"
    
    ' 读取源数据最后一行，将数据存入数组（比逐行读取快10倍以上）
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    arrData = wsSource.Range("A1:C" & lastRow).Value
    
    ' 用字典存储每个账户对应的联系人+邮箱集合
    Set accountDict = CreateObject("Scripting.Dictionary")
    
    ' 遍历源数据（跳过表头，从第2行开始）
    For i = 2 To UBound(arrData)
        key = arrData(i, 1) ' 以账户作为字典的键
        ' 若账户未在字典中，新建集合存储其联系人信息
        If Not accountDict.Exists(key) Then
            Set contactList = New Collection
            accountDict.Add key, contactList
        End If
        ' 将联系人与邮箱存入对应账户的集合
        accountDict(key).Add Array(arrData(i, 2), arrData(i, 3))
    Next i
    
    ' 确定输出数组的列数：账户列 + 最大联系人数量×2（联系人+邮箱为一组）
    Dim maxContacts As Integer
    maxContacts = 0
    For Each key In accountDict.Keys
        If accountDict(key).Count > maxContacts Then
            maxContacts = accountDict(key).Count
        End If
    Next key
    ReDim arrOutput(1 To accountDict.Count + 1, 1 To 1 + maxContacts * 2)
    
    ' 设置表头
    arrOutput(1, 1) = "账户"
    For colIndex = 1 To maxContacts
        arrOutput(1, colIndex * 2) = "联系人" & colIndex
        arrOutput(1, colIndex * 2 + 1) = "邮箱" & colIndex
    Next colIndex
    
    ' 填充输出数组
    i = 2 ' 从第2行开始写入数据
    For Each key In accountDict.Keys
        arrOutput(i, 1) = key ' 写入账户名
        colIndex = 2 ' 从第2列开始写入联系人与邮箱
        For Each item In accountDict(key)
            arrOutput(i, colIndex) = item(0) ' 联系人
            arrOutput(i, colIndex + 1) = item(1) ' 邮箱
            colIndex = colIndex + 2
        Next item
        i = i + 1
    Next key
    
    ' 将结果批量写入目标工作表
    wsDest.Range("A1").Resize(UBound(arrOutput, 1), UBound(arrOutput, 2)).Value = arrOutput
    
    ' 自动调整列宽
    wsDest.Columns.AutoFit
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox "合并完成！结果已存入新工作表：" & wsDest.Name, vbInformation
End Sub

使用步骤 #

1. 打开CSV文件，将文件另存为.xlsm格式（启用宏的工作簿）
2. 按下Alt + F11打开VBA编辑器
3. 右键点击项目窗口中的工作簿名称 → 插入 → 模块
4. 将上述代码粘贴到模块中
5. 返回Excel，按下Alt + F8，选择MergeAccountContacts宏并执行

自定义说明 #

• 若你的源数据列位置不同（比如账户在B列、邮箱在D列），需修改代码中arrData(i, 1)、arrData(i, 2)、arrData(i, 3)的索引，以及源数据范围Range("A1:C" & lastRow)
• 处理60万行数据前，建议关闭其他占用内存的程序，确保Excel有足够运行空间

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