Excel VBA优化：识别同日同人员多记录并转置第三列数据

针对你这个Excel数据合并转置的需求，结合1万行的大数据量，我强烈推荐用字典（Dictionary）+ 数组的方案来替代原来的行号索引循环——这个组合不仅效率拉满，逻辑也更清晰，完全避免了逐行跳转判断的繁琐。

核心思路 #

• 批量读入数组：把原始数据一次性读进内存数组，避免频繁操作工作表（这是VBA处理大数据的关键优化点）。
• 字典分组聚合：用字典的键来唯一标识「日期+人员」的组合，对应的值用来收集该组合下所有的Column3数据，快速完成分组。
• 批量写入结果：把字典里的分组数据整理成输出数组，一次性写入目标工作表，再次减少工作表交互开销。

完整VBA代码 #

Sub MergeAndTransposeRecords()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim arrSource As Variant, arrOutput As Variant
    Dim dict As Object
    Dim i As Long, j As Long, outputRow As Long
    Dim key As String
    Dim col3Values As Variant
    
    ' 定义源工作表和目标工作表（可根据实际修改）
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 读取源数据到数组（假设数据从A1开始，包含表头）
    arrSource = wsSource.UsedRange.Value
    
    ' 遍历源数组，填充字典分组
    ' 从第2行开始跳过表头
    For i = 2 To UBound(arrSource, 1)
        ' 构建唯一键：日期+分隔符+人员，避免不同组合冲突
        key = CStr(arrSource(i, 1)) & "|" & CStr(arrSource(i, 2))
        
        If dict.Exists(key) Then
            ' 如果键已存在，追加Column3的值到集合
            dict(key).Add arrSource(i, 3)
        Else
            ' 如果键不存在，新建集合并添加第一个值
            Set dict(key) = New Collection
            dict(key).Add arrSource(i, 3)
        End If
    Next i
    
    ' 准备输出数组：行数=字典条目数，列数=日期+人员+最多6个Column3值
    ReDim arrOutput(1 To dict.Count, 1 To 8) ' 1(日期)+1(人员)+6(Column3) = 8列
    
    ' 填充输出数组
    outputRow = 1
    For Each key In dict.Keys
        ' 拆分键，获取日期和人员
        arrOutput(outputRow, 1) = Split(key, "|")(0)
        arrOutput(outputRow, 2) = Split(key, "|")(1)
        
        ' 转置Column3的值到后续列，最多取6条
        Set col3Values = dict(key)
        For j = 1 To Application.Min(col3Values.Count, 6)
            arrOutput(outputRow, 2 + j) = col3Values(j)
        Next j
        
        outputRow = outputRow + 1
    Next key
    
    ' 清空目标表原有数据，写入结果
    wsTarget.Cells.Clear
    ' 写入表头（可根据实际修改表头文本）
    wsTarget.Range("A1:H1").Value = Array("日期", "人员", "记录1", "记录2", "记录3", "记录4", "记录5", "记录6")
    ' 写入数据
    wsTarget.Range("A2").Resize(UBound(arrOutput, 1), UBound(arrOutput, 2)).Value = arrOutput
    
    ' 释放对象
    Set dict = Nothing
    Set wsSource = Nothing
    Set wsTarget = Nothing
    
    MsgBox "数据处理完成！", vbInformation
End Sub

方案优势 #

• 效率极高：数组读写+字典分组的时间复杂度接近O(n)，处理1万行数据几乎瞬间完成，远优于逐行判断行号的循环方案。
• 逻辑清晰：用字典天然实现分组，不用手动跟踪行号、判断同一日期人员的边界，代码可读性和维护性更强。
• 扩展性好：如果后续需要调整最多记录数（比如从6条改成8条），只需要修改数组列数和Min函数的参数即可。

注意事项 #

1. 确保源数据已经按「日期+人员」排序（你提到已经排序了，这会让字典分组的过程更顺畅，但即使没排序，这个方案也能正常工作）。
2. 如果你的源数据没有表头，记得把遍历数组的起始行从2改成1，并去掉写入表头的代码。
3. 运行前要确保启用了Scripting.Dictionary（代码里用CreateObject方式创建，不需要手动引用，兼容性更好）。

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