合并行使用词典在总和和最大值/最小值的VBA到某些列

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

我想要一个最终的结果，所有4行被合并成1行，其中有4条原始行总计收入金额。 另外每一行都有开始和结束date。 我需要最后的合并行将最早的（ MIN ）开始date和最后的（ MAX ）结束date作为合并行的最终结果。

我要整理的目标行并不总是连续的，因此我认为字典将是他们要走的路（在这个path中，唯一的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 

目前代码运行没有错误，我得到预期的行数输出到新的“合并光盘数据”表。 然而，列AJ（36）并不总和。 看起来，不pipeAJ栏中的值是多less，最后一行的合并都是简单的加倍（不加到需要合并的其他行）。 这不仅发生在输出表上，而且还发生在原始数据集上（我不想）。

我不知道如何将MIN / MAXfunction应用于我的开始和结束date。 任何帮助（或任何部分）非常感谢。 开始date在列O和结束date在列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 

build议（per @RonRosenfeld）为字典值使用Class ，例如Class1 （只需在VB编辑器中创build一个新类），然后input：

 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与该行的数据
• 如果密钥不是新的，则获取现有数据并增加收入并比较date以获得合并项目的开始和结束

码：

 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 

你应该能够适应你的数据集。 为了对date进行最小/最大testing，build议的代码只使用存储在数据包中的当前date（例如Class1属性）和正在处理的行的date之间的< and >

 ' 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

编辑

根据关于仅印刷关键date和收入的评论问题，您可以为class级添加额外的字段：

 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 eg 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