Excel VBA - 在一个单元格中合并具有重复值的行并合并其他单元格中的值

Question

如果 A 列中有重复值，我希望 C-E 列求和，B 列和 F 列显示出现的第一个值。

例如：

A    B    C    D    E    F
h    4    2    3    1    5
h    3    3    5    3    7
h    4    4    7    5    4
h    1    1    4    1    4
k    9    3    6    2    4
k    5    3    6    2    7
k    4    3    9    2    7
k    9    4    1    1    4

会变成：

A    B    C    D    E    F
h    4   10   19   10   5
k    9   13   22   7    4

这是我在获得 4 列时使用的代码，它运行良好。现在我正在编辑的文档有 6 列，我现在无法使用它。

Sub mergeCategoryValues()
    Dim lngRow As Long

    With ActiveSheet
        lngRow = .Cells(65536, 1).End(xlUp).Row
        .Cells(1).CurrentRegion.Sort key1:=.Cells(1), Header:=xlYes

        Do
            If .Cells(lngRow, 1) = .Cells(lngRow - 1, 1) Then
                .Cells(lngRow - 1, 3) = .Cells(lngRow - 1, 3) + .Cells(lngRow, 3)
                .Cells(lngRow - 1, 4) = .Cells(lngRow - 1, 4) + .Cells(lngRow, 4)
                .Rows(lngRow).Delete
            End If

            lngRow = lngRow - 1
        Loop Until lngRow = 1
    End With
End Sub

有人可以帮忙吗？提前致谢。

Answer 1

请注意，我在下面的代码中添加了两个新语句来汇总您的两个 add'l 列，即：

.Cells(lngRow - 1, 5) = .Cells(lngRow - 1, 5) + .Cells(lngRow, 5)
.Cells(lngRow - 1, 6) = .Cells(lngRow - 1, 6) + .Cells(lngRow, 6)

基本上，您提供的代码从工作表的 最后 行开始，逐行向上，将当前行的值添加到其正上方的行中，如果第 1 列中的值匹配。我添加的5 和6 行指的是要聚合的列号。

Sub mergeCategoryValues()
Dim lngRow As Long

With ActiveSheet
    lngRow = .Cells(65536, 1).End(xlUp).Row
    .Cells(1).CurrentRegion.Sort key1:=.Cells(1), Header:=xlYes

    Do
        If .Cells(lngRow, 1) = .Cells(lngRow - 1, 1) Then
            .Cells(lngRow - 1, 3) = .Cells(lngRow - 1, 3) + .Cells(lngRow, 3)
            .Cells(lngRow - 1, 4) = .Cells(lngRow - 1, 4) + .Cells(lngRow, 4)

            ' added the next two statements for your new columns
            .Cells(lngRow - 1, 5) = .Cells(lngRow - 1, 5) + .Cells(lngRow, 5)
            .Cells(lngRow - 1, 6) = .Cells(lngRow - 1, 6) + .Cells(lngRow, 6)
            .Rows(lngRow).Delete
        End If

        lngRow = lngRow - 1
    Loop Until lngRow = 1
End With
End Sub

Answer 2

您也可以使用 Windows Excel 2010+ 和 O365 中提供的 Power Query 执行此操作 这实际上只是按 A 列分组的一个步骤，并对 B..F 列进行正确的聚合。下面 MCode 的第三行是所有魔法发生的地方。

• 注意使用以下任一方法，都不需要对数据进行排序。
• 此外，任何一个都可以轻松修改以添加/删除列；和/或决定为哪些行返回 SUM 或 FIRST 条目。

虽然您可以将 M 代码粘贴到高级编辑器中，但我建议您自己完成生成它的步骤，特别是如果您的列具有不同的名称，或者值不是整数时

• 选择表格中的某个单元格
• 数据/获取&转换/来自表/范围
• 当 PQ 编辑器打开时
• 选择A列和group by
• 选择高级
  • 为每列 B..F 输入一个 Sum 聚合
  • 完成之后
    • 主页 / 高级编辑器
    • 您会看到 Table.Group 行对每个聚合列都有多个 List.Sum 操作。
      • 将第二列和最后一列的 List.Sum 更改为 List.First。
      • 您还可以在同一行代码中更改列标题。

M 码

    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"A", type text}, {"B", Int64.Type}, {"C", Int64.Type}, {"D", Int64.Type}, {"E", Int64.Type}, {"F", Int64.Type}}),
    #"Grouped Rows" = Table.Group(#"Changed Type", {"A"}, {{"First B", each List.First([B]), type nullable number}, 
        {"Sum C", each List.Sum([C]), type nullable number}, {"Sum D", each List.Sum([D]), type nullable number},
        {"Sum E", each List.Sum([E]), type nullable number},{"First F", each List.First([F]), type nullable number}})
in
    #"Grouped Rows"

如果您必须使用 VBA，我建议将 A 列中每个项目的数据收集到一个字典中，其中字典条目是另一个字典，它对每一列的值求和（第一个除外和最后一列，仅保留第一个值）。

请注意，我们在 VBA 数组中工作，因为它通常比在工作表中工作/从工作表中工作快一个数量级。

'Set reference to Microsoft Scripting Runtime (preferable)
'or convert to late binding
Option Explicit
Sub mergeCategoryValues()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim Da As Dictionary, Dv As Dictionary
    Dim I As Long, J As Long, sKeyA As String
    Dim v, w
    
'set the Source and results worksheets, ranges
Set wsSrc = Worksheets("sheet6")
Set wsRes = Worksheets("sheet6")
    Set rRes = wsRes.Cells(12, 16)
    
'read source data into vba array for faster processing
With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=6)
End With

'read the values into dictionaries
'each dictionary of col a will contain dictionary with the other column values, either summed or just first
Set Da = New Dictionary
    Da.CompareMode = TextCompare
    
For I = 2 To UBound(vSrc, 1) 'skip the header row
    sKeyA = vSrc(I, 1)
    
    'initial set up for column A ID
    If Not Da.Exists(sKeyA) Then
        Set Dv = New Dictionary
            Dv.CompareMode = TextCompare
        For J = 2 To UBound(vSrc, 2)
            Dv.Add Key:=vSrc(1, J), Item:=vSrc(I, J)
        Next J
        
        Da.Add Key:=sKeyA, Item:=Dv
        
    Else  'Column A entry already exists
        'we just add the value from  column C..next to last column
        '  leaving the first entry in columns A and the last column
        For J = 3 To UBound(vSrc, 2) - 1
            Da(sKeyA)(vSrc(1, J)) = Da(sKeyA)(vSrc(1, J)) + vSrc(I, J)
        Next J
    End If
Next I

'can sort the Da keys if necessary
'create results array
ReDim vRes(0 To Da.Count, 1 To UBound(vSrc, 2))

'Headers
For J = 1 To UBound(vSrc, 2)
    vRes(0, J) = vSrc(1, J)
Next J

'Data
I = 0
For Each v In Da.Keys
    I = I + 1
    vRes(I, 1) = v
    J = 1
    For Each w In Da(v)
        J = J + 1
        vRes(I, J) = Da(v)(w)
    Next w
Next v

'write to the worksheet
Set rRes = rRes.Resize(rowsize:=UBound(vRes, 1) + 1, columnsize:=UBound(vRes, 2))
Application.ScreenUpdating = False
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .HorizontalAlignment = xlCenter
    .Style = "Output" 'can change or ignore this, especially if non-english version
    .EntireColumn.AutoFit
End With
     
End Sub