如何使用Excel VBA将重复行的E列数据转置为列并去重A-D列

问题描述 #

我目前正尝试使用Excel VBA清理一份大型数据集，数据集结构如下所示。

我期望调整为如下结构：若A-D列的单元格值全部相同，则将对应E列的单元格内容转置为多列，同时删除A-D列的重复条目，目标效果如下所示。

以下是我已编写的代码：

Dim ws As Worksheet: Set ws = Sheets("test")
lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

Dim j As Integer
j = 6

For i = 2 To lastrow

    If (Range("A" & i).Value = Range("A" & i + 1).Value) And (Range("B" & i).Value = Range("B" & i + 1).Value) And (Range("C" & i).Value = Range("C" & i + 1).Value) Then
        Cells(i, j).Value = Cells(i + 1, 5).Value
        j = j + 1
    End If
    
    'Reset J back to 6 if columns A to D does not match previous
    If (Range("A" & i).Value <> Range("A" & i + 1).Value) Or (Range("B" & i).Value <> Range("B" & i + 1).Value) Or (Range("C" & i).Value <> Range("C" & i + 1).Value) Then
        j = 6
    End If
    
Next i

请问该如何实现该需求？

解决方案 #

你原有代码存在三个核心问题：仅校验了A-C列的匹配逻辑，未覆盖D列；没有处理重复行删除的逻辑；逐行操作单元格效率低，不适合大型数据集。
以下是可直接运行的实现代码，用字典聚合同组E列数据，批量操作避免卡顿：

Sub TransposeGroupData()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long, outputRow As Long, col As Long
    Dim dict As Object, key As String, eValues As Variant
    
    ' 初始化工作表和字典（后期绑定无需引用库）
    Set ws = ThisWorkbook.Sheets("test")
    Set dict = CreateObject("Scripting.Dictionary")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历原始数据聚合同组E列值
    For i = 2 To lastRow
        ' 用A-D列拼接成唯一分组键
        key = ws.Range("A" & i).Value & "|" & ws.Range("B" & i).Value & "|" & _
              ws.Range("C" & i).Value & "|" & ws.Range("D" & i).Value
        ' 新分组则初始化E值数组
        If Not dict.exists(key) Then
            dict.Add key, Array(ws.Range("E" & i).Value)
        Else
            ' 已有分组追加E列值
            eValues = dict(key)
            ReDim Preserve eValues(UBound(eValues) + 1)
            eValues(UBound(eValues)) = ws.Range("E" & i).Value
            dict(key) = eValues
        End If
    Next i
    
    ' 清空原有数据区域（保留表头）
    ws.Range("A2:Z" & lastRow).ClearContents
    outputRow = 2
    
    ' 批量写回处理后的数据
    For Each key In dict.keys
        ' 拆分分组键写回A-D列
        eValues = Split(key, "|")
        For col = 0 To 3
            ws.Cells(outputRow, col + 1).Value = eValues(col)
        Next col
        ' 写回转置后的多列E值
        eValues = dict(key)
        For col = 0 To UBound(eValues)
            ws.Cells(outputRow, 5 + col).Value = eValues(col)
        Next col
        outputRow = outputRow + 1
    Next key
    
    ' 释放对象
    Set dict = Nothing
    Set ws = Nothing
End Sub

说明 #

• 默认保留第一行表头，数据从第二行开始处理，可根据实际情况调整起始行号
• 采用数组+字典的批量处理逻辑，大型数据集下运行效率远高于逐单元格操作
• A-D列的空值会被视为有效分组依据，符合通用的去重逻辑

内容的提问来源于stack exchange，提问作者ta.ng