Excel 合并行&；工作表中的求和值

我有一个excel表格，其中包含以下（用管道“|”分隔列）数据

我试图得到的结果是：

A|B|C|X|80|150
A|B|C|Y|30|30
D|E|F|X|50|80

值A、B、C和D、E、F类似于唯一标识符。实际上，只能考虑A或D。值X和Y类似于“类型”，整数是要求和的值。此示例经过简化，有数千个唯一标识符、十几种类型和几十个值可求和。行未排序，类型可以位于较高或较低的行中。我试图避免使用透视表

Dim LastRow As Integer
Dim LastCol As Integer
Dim i As Integer

LastCol = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
LastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To LastRow
????
Next i

上面的代码到达了循环行的点，但我不清楚在这一点之后应该做什么

在您认为重要的所有字母列上对它们进行排序

在右侧未使用的列中，在第二行中使用如下公式

=如果（$A2&$B2&$C2&$D2=$A3&$B3&$C3&$D3，“”，SUMIFS（E:E，$A:$A，$A2，$B:$B，$B2，$C:$C，$C2，$D:$D，$D2））

将公式右移一列，然后将两列都填充到数据所在的位置

对两列进行过滤，去除空白

（可选）将数据复制到新的报告工作表并删除E&F列

附录：

通过某种形式的数组和一些简单的数学运算，可以实现更自动化的方法。我选择了dictionary对象，以便使用其索引键识别前四个字母标识符中的模式

要使用脚本字典，您需要进入VBE的工具► 引用并添加Microsoft脚本运行时。没有它，以下代码将无法编译

以下内容已针对键和整数的动态列进行了调整

Sub rad_collection()
    Dim rw As Long, nc As Long, sTMP As String, v As Long, vTMP As Variant
    Dim i As Long, iNumKeys As Long, iNumInts As Long
    Dim dRADs As New Scripting.Dictionary

    dRADs.CompareMode = vbTextCompare
    iNumKeys = 5    'possibly calculated by num text (see below)
    iNumInts = 2    'possibly calculated by num ints (see below)

    With ThisWorkbook.Sheets("Sheet4").Cells(1, 1).CurrentRegion
        'iNumKeys = Application.CountA(.Rows(2)) - Application.Count(.Rows(2))  'alternate count of txts
        'iNumInts = Application.Count(.Rows(2))    'alternate count of ints
        For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).row
                vTMP = .Cells(rw, 1).Resize(1, iNumKeys).Value2
                sTMP = Join(Application.Index(vTMP, 1, 0), Chr(183))
                If Not dRADs.Exists(sTMP) Then
                    dRADs.Add Key:=sTMP, Item:=Join(Application.Index(.Cells(rw, iNumKeys + 1).Resize(1, iNumInts).Value2, 1, 0), Chr(183))
                Else
                    vTMP = Split(dRADs.Item(sTMP), Chr(183))
                    For v = LBound(vTMP) To UBound(vTMP)
                        vTMP(v) = vTMP(v) + .Cells(rw, iNumKeys + 1 + v).Value2
                    Next v
                    dRADs.Item(sTMP) = Join(vTMP, Chr(183))
                End If

        Next rw

        rw = 1
        nc = iNumKeys + iNumInts + 1
        .Cells(rw, nc + 1).CurrentRegion.ClearContents  'clear previous
        .Cells(rw, nc + 1).Resize(1, nc - 1) = .Cells(rw, 1).Resize(1, nc - 1).Value2
        For Each vTMP In dRADs.Keys
            'Debug.Print vTMP & "|" & dRADs.Item(vTMP)
            rw = rw + 1
            .Cells(rw, nc + 1).Resize(1, iNumKeys) = Split(vTMP, Chr(183))
            .Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts) = Split(dRADs.Item(vTMP), Chr(183))
            .Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts) = _
              .Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts).Value2
        Next vTMP
    End With

    dRADs.RemoveAll: Set dRADs = Nothing

End Sub

只需根据作为示例提供的数字运行宏。我在第一行假设了某种形式的列标题标签。将填充dictionary对象，并将组合标识符中的重复项的编号相加。剩下的就是将它们重新拆分并返回到工作表中未使用的区域

Microsoft脚本运行时的位置-在Visual Basic编辑器（又名VBE）中选择工具► 引用（Alt+T，R）并向下滚动到一半多一点以找到它

---

所以如果我理解你的问题，对于列A、B、C、D中的每个唯一值组合，你想分别对列E和F求和吗？如果是这样，你打算把结果放在哪里？您需要使用一个数组来存储组合（cols A&B&C&D）和两个和。当您从一行转到另一行时，您会查看数组中是否已经存在该组合。如果是，将新的E，F值添加到数组中已有的值中。如果组合不存在，则使用此新组合在数组末尾添加一个新条目，并存储E、F值。结果将出现在第一个唯一标识符行中。具有唯一标识符的第一行保留下来，并从其他行（已删除）中获取其总和。Lol，这不是作业。这些记录是PRM-9000的辐射测量结果：汉克斯·吉佩德：有效！但是除了公式之外，没有其他方法了吗？我正在寻找一个VBA唯一的解决方案，谢谢！看起来太棒了！但是我在Dim Drad上得到了一个“编译错误，用户定义类型未定义。”作为新脚本。Dictionary：（知道是什么导致了错误吗？不用担心。很抱歉，我不太清楚。我使用Excel 2010（在Windows 7上），找不到Windows脚本运行时。似乎我必须下载它。您使用的Excel版本是什么？您也必须下载它吗？没有Windows脚本运行时，有什么方法可以下载它吗？我尝试下载/安装WSR，但它给了我错误：（似乎脚本字典的替代品是数组。）（我正试着在这个话题上教育自己）。谢谢你。真不敢相信我错过了。一切都很有魅力。积极学习你写的东西，熟悉数组，但不是像那样复杂的数组。

Sub rad_collection()
    Dim rw As Long, nc As Long, sTMP As String, v As Long, vTMP As Variant
    Dim i As Long, iNumKeys As Long, iNumInts As Long
    Dim dRADs As New Scripting.Dictionary

    dRADs.CompareMode = vbTextCompare
    iNumKeys = 5    'possibly calculated by num text (see below)
    iNumInts = 2    'possibly calculated by num ints (see below)

    With ThisWorkbook.Sheets("Sheet4").Cells(1, 1).CurrentRegion
        'iNumKeys = Application.CountA(.Rows(2)) - Application.Count(.Rows(2))  'alternate count of txts
        'iNumInts = Application.Count(.Rows(2))    'alternate count of ints
        For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).row
                vTMP = .Cells(rw, 1).Resize(1, iNumKeys).Value2
                sTMP = Join(Application.Index(vTMP, 1, 0), Chr(183))
                If Not dRADs.Exists(sTMP) Then
                    dRADs.Add Key:=sTMP, Item:=Join(Application.Index(.Cells(rw, iNumKeys + 1).Resize(1, iNumInts).Value2, 1, 0), Chr(183))
                Else
                    vTMP = Split(dRADs.Item(sTMP), Chr(183))
                    For v = LBound(vTMP) To UBound(vTMP)
                        vTMP(v) = vTMP(v) + .Cells(rw, iNumKeys + 1 + v).Value2
                    Next v
                    dRADs.Item(sTMP) = Join(vTMP, Chr(183))
                End If

        Next rw

        rw = 1
        nc = iNumKeys + iNumInts + 1
        .Cells(rw, nc + 1).CurrentRegion.ClearContents  'clear previous
        .Cells(rw, nc + 1).Resize(1, nc - 1) = .Cells(rw, 1).Resize(1, nc - 1).Value2
        For Each vTMP In dRADs.Keys
            'Debug.Print vTMP & "|" & dRADs.Item(vTMP)
            rw = rw + 1
            .Cells(rw, nc + 1).Resize(1, iNumKeys) = Split(vTMP, Chr(183))
            .Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts) = Split(dRADs.Item(vTMP), Chr(183))
            .Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts) = _
              .Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts).Value2
        Next vTMP
    End With

    dRADs.RemoveAll: Set dRADs = Nothing

End Sub