使用带有 Sum 和 Max/Min 的 VBA 中的字典将行合并到某些列

Question

我正在尝试合并具有多个属性（例如订单号和产品号）的数据行。例如：订单 12345 有 4 行数据，所有数据都具有相同的产品编号，但每一行都有唯一的收入金额。

我想要一个最终结果，将所有 4 行合并为 1 行，其中的收入金额来自 4 个原始行。此外，每一行都有一个开始和结束日期。我需要最后的合并行将最早 (MIN) 开始日期和最后 (MAX) 结束日期作为合并行中的最终结果。

我要合并的目标行在数据中并不总是连续的，因此我认为字典将是他们的方式（其中唯一的 ID（用于标识需要合并的行）是我的“关键” ）。我在这里发现了一个类似的问题，并使用该答案中的代码来达到我现在的位置。

我有一个“唯一 ID”，它确定哪些行需要合并在一起（如果 ID 相同，则需要合并行）。唯一 ID 是 4 列（订单号、产品、合同名称和状态）的串联。

我当前的代码是：

Dim oRange As Range
Dim oTarget As Range
Dim oRow As Range
Dim oRowAmend As Range
Dim oDic As Scripting.Dictionary
Dim sIndex As String
Dim vKey As Variant
Dim vItem As Variant
Dim LastRow As Long


Worksheets("ODD Data").Activate

 LastRow = Worksheets("ODD Data").Range("A" & Rows.Count).End(xlUp).Row

  'Define the source range
Set oRange = Sheets("ODD Data").Range("A2:CE" & LastRow)

'Define where the updated data will be printed.
Set oTarget = Sheets("Consolidated ODD Data").Range("A2:CE2")

Set oDic = New Scripting.Dictionary

For Each oRow In oRange.Rows

    'Define Indexes (what is checked for duplicates)

sIndex = oRow.Cells(82) 'Column 82 is my unique ID column 

    'If the index exists, sum the values
    If oDic.Exists(sIndex) Then

        Set oRowAmend = oRow

 oRowAmend.Cells(36).Value = oRow.Cells(36).Value + oRowAmend.Cells(36).Value 'Column 36 is the column which has the revenue amount I wish to sum


        oDic.Remove (sIndex)
        oDic.Add sIndex, oRowAmend

    'If does not exist, only store their values
    Else

        oDic.Add sIndex, oRow

    End If

Next oRow


For Each vKey In oDic

    vItem = oDic.Item(vKey)
    oTarget = vItem

    'Points oTarget for next row
    Set oTarget = oTarget.Offset(1, 0)

Next vKey

End Sub

目前代码运行没有错误，我得到了预期的行数输出到新的“合并 ODD 数据”表中。然而，AJ 列 (36) 没有求和。看来，无论 AJ 列中的值对于要合并的最后一行是什么，都只是加倍（不添加到需要合并的其他行）。这不仅发生在输出表上，而且还发生在原始数据集上（我不想要）。

我不知道如何将 MIN / MAX 功能应用于我的开始日期和结束日期。非常感谢对此（或任何部分）的任何帮助。开始日期在 O 列中，结束日期在 P 列中。我要合并的行之间的所有其他列都是相同的。

我想知道我是否需要将一个数组作为我的字典中的一个项目进行报道？我是新手，有点不知所措！

非常感谢！

Answer 1

考虑Sheet1 中从A1 开始的这些数据：

| Row | Key             | Order | Product | Contract | State | Value | Start    | End      |
|-----|-----------------|-------|---------|----------|-------|-------|----------|----------|
| 1   | aaa|123|foo|bar | aaa   | 123     | foo      | bar   | 11    | 27-11-17 | 08-01-18 |
| 2   | bbb|456|foo|bar | bbb   | 456     | foo      | bar   | 11    | 22-11-17 | 23-12-17 |
| 3   | aaa|123|foo|bar | aaa   | 123     | foo      | bar   | 10    | 30-11-17 | 05-01-18 |
| 4   | bbb|456|foo|bar | bbb   | 456     | foo      | bar   | 13    | 03-12-17 | 08-01-18 |
| 5   | aaa|456|foo|bar | aaa   | 456     | foo      | bar   | 27    | 04-12-17 | 24-12-17 |
| 6   | bbb|123|foo|bar | bbb   | 123     | foo      | bar   | 6     | 12-12-17 | 26-12-17 |
| 7   | bbb|123|foo|bar | bbb   | 123     | foo      | bar   | 9     | 10-12-17 | 30-12-17 |
| 8   | bbb|456|foo|bar | bbb   | 456     | foo      | bar   | 11    | 04-12-17 | 06-01-18 |
| 9   | bbb|456|foo|bar | bbb   | 456     | foo      | bar   | 24    | 28-11-17 | 23-12-17 |
| 10  | bbb|456|foo|bar | bbb   | 456     | foo      | bar   | 27    | 26-11-17 | 06-01-18 |
| 11  | aaa|123|foo|bar | aaa   | 123     | foo      | bar   | 3     | 27-11-17 | 07-01-18 |
| 12  | aaa|123|foo|bar | aaa   | 123     | foo      | bar   | 1     | 02-12-17 | 24-12-17 |
| 13  | bbb|456|foo|bar | bbb   | 456     | foo      | bar   | 26    | 01-12-17 | 03-01-18 |
| 14  | aaa|123|foo|bar | aaa   | 123     | foo      | bar   | 26    | 05-12-17 | 31-12-17 |
| 15  | aaa|123|foo|bar | aaa   | 123     | foo      | bar   | 24    | 08-12-17 | 21-12-17 |

Key 的公式为：

=C2&"|"&D2&"|"&E2&"|"&F2

建议您（根据@RonRosenfeld）使用Class 作为字典值，例如Class1（只需在VB编辑器中新建一个类）然后输入：

Option Explicit

Public ConsolidatedRevenue As Double
Public FirstDate As Date
Public LastDate As Date

然后你可以使用这样的代码（支持智能感知）：

Dim obj As Class1
Set obj = New Class1
obj.ConsolidatedRevenue = 99 
obj.ConsolidatedRevenue = obj.ConsolidatedRevenue + 99 

所以，下面的代码将：

• 循环每一行
• 如果键不在字典中，则添加键和带有该行数据的新 Class1
• 如果键不是新的，则获取现有数据并增加收入并比较日期以获取合并项目的开始和结束

代码：

Option Explicit

Sub Consolidate()

    Dim ws As Worksheet
    Dim rngData As Range
    Dim objDic As Object
    Dim lngCounter As Long
    Dim varKey As Variant
    Dim dblRevenue As Double
    Dim dtStart As Date
    Dim dtEnd As Date
    Dim objData As Class1

    Set ws = ThisWorkbook.Worksheets("Sheet1") '<-- change to your worksheet
    Set rngData = ws.Range("A2:I16") '<-- change to your range with last row etc
    Set objDic = CreateObject("Scripting.Dictionary") '<-- late bound reference to dictionary

    For lngCounter = 1 To rngData.Rows.Count
        varKey = rngData.Cells(lngCounter, 2).Value '<-- the key
        dblRevenue = CDbl(rngData.Cells(lngCounter, 7).Value) '<-- the revenue
        dtStart = CDate(rngData.Cells(lngCounter, 8).Value) '<-- the start date on row
        dtEnd = CDate(rngData.Cells(lngCounter, 9).Value) '<-- the end date on row

        ' test for key in dictionary
        If objDic.Exists(varKey) Then

            ' get existing data packet
            Set objData = objDic(varKey)

            ' increment revenue
            objData.ConsolidatedRevenue = objData.ConsolidatedRevenue + CDbl(rngData.Cells(lngCounter, 7))

            ' update first date if earlier
            If dtStart < objData.FirstDate Then
                objData.FirstDate = dtStart
            End If

            ' update last date if later
            If dtEnd > objData.LastDate Then
                objData.LastDate = dtEnd
            End If

        Else

            ' create a new data packet
            Set objData = New Class1

            ' set properties for new item
            objData.ConsolidatedRevenue = dblRevenue
            objData.FirstDate = dtStart
            objData.LastDate = dtEnd

            ' store new data packet in dictionary
            objDic.Add varKey, objData

        End If
    Next lngCounter

    ' test dictionary
    For Each varKey In objDic.Keys
        ' output could go to another sheet instead of immediate window...
        Debug.Print "Key: " & varKey
        Debug.Print "Revenue: " & objDic(varKey).ConsolidatedRevenue
        Debug.Print "First Date: " & objDic(varKey).FirstDate
        Debug.Print "End Date: " & objDic(varKey).LastDate
    Next varKey

End Sub

输出是：

Key: aaa|123|foo|bar
Revenue: 75
First Date: 27-Nov-17
End Date: 08-Jan-18
Key: bbb|456|foo|bar
Revenue: 112
First Date: 22-Nov-17
End Date: 08-Jan-18
Key: aaa|456|foo|bar
Revenue: 27
First Date: 04-Dec-17
End Date: 24-Dec-17
Key: bbb|123|foo|bar
Revenue: 15
First Date: 10-Dec-17
End Date: 30-Dec-17

您应该能够使其适应您的数据集。要对日期进行最小/最大测试，建议的代码只需在数据包中存储的当前日期（例如 Class1 属性）和正在处理的行的日期之间使用 < 和 >：

' update first date if earlier
If dtStart < objData.FirstDate Then
    objData.FirstDate = dtStart
End If

' update last date if later
If dtEnd > objData.LastDate Then
    objData.LastDate = dtEnd
End If

HTH

编辑

根据关于仅打印关键日期和收入的评论问题 - 您可以在课程中添加额外的字段：

Option Explicit

Public ConsolidatedRevenue As Double
Public FirstDate As Date
Public LastDate As Date
Public Order As String
Public Product As String
Public Contract As String
Public State As String
'... etc

然后在主循环中，获取这些附加值，例如

' ... (Dim them all first e.g. Dim strOrder As String etc)
strOrder = rngData.Cells(lngCounter, 3).Value
strProduct = rngData.Cells(lngCounter, 4).Value
strContract = rngData.Cells(lngCounter, 5).Value
strState = rngData.Cells(lngCounter, 6).Value
' ...

然后你可以将它们添加到Class1的实例中：

' ...
objData.Order = strOrder
objData.Product = strProduct
objData.Contract = strContract
objData.State = strState
' ... etc

然后当你循环字典时，你可以输出它们，例如

Dim wsOutput As Worksheet
Set wsOutput = ThisWorkbook.Worksheets("Output") '<-- change to your output sheet
' loop the dictionary
Dim lng As Long
For lng = 0 To objDic.Count - 1
    ' ... instead of Debug.Print output to sheet with wsOutput.Cells(x, y).Value = foo
    Set objData = objDic.Items()(lng)
    wsOutput.Cells(lng + 1, 1).Value = objData.Order
    wsOutput.Cells(lng + 1, 2).Value = objData.Product
    wsOutput.Cells(lng + 1, 3).Value = objData.Contract
    wsOutput.Cells(lng + 1, 4).Value = objData.State
    wsOutput.Cells(lng + 1, 5).Value = objData.FirstDate
    wsOutput.Cells(lng + 1, 6).Value = objData.LastDate
    wsOutput.Cells(lng + 1, 7).Value = objData.ConsolidatedRevenue
    ' ... etc
Next lng