我需要一些帮助来学习如何在 VBA 中按层次结构分组汇总数据(由于"最终用户"的限制，数据透视表甚至表都不够用)。
我有粒度数据，具有三个级别的分组：父级、子级、谷物。 父母一方可以有1个以上的孩子;每个孩子可以有1个以上的谷物。 我需要获取粒度数据并执行一些计算，然后生成父级和子级的报告。 为了便于说明，以下是源和所需输出的假设结构/布局。
我已经探索过使用字典和集合，但似乎两者都无法限制为唯一/不同的关系。 例如，字典将限制为不同的键，但允许重复的字符串值。
For example: Plants: Edible_Or_Not / Classification / Type / item
Edible / Fruit / Apple / Granny Smith
Edible / Fruit / Apple / Red Delicious
Edible / Vegetable / Asparagus / Asparagus
Nonedible / Tree / Maple / Red
Summaries:
1) Edible composed of Fruit and Vegetable
2) Fruit composed of Apple
3) Apple composed of Granny Smith and Red Delicious.
以下是更准确地表示我的数据的布局。
Source:|||||
Parent Category Label|Child Category Label|Granular Label|DataPoint1|DataPoint2…|DataPoint3
---|---|---|---|---|---|
String A|String z|string z.g1.g2.g3|5|FALSE|1/1/1960
String A|String y|String y.g1.g2.g3|0|TRUE|1/2/1970
String B|String w|String w.g1.g2.g3|0|TRUE|9/5/1980
String C|String m|String m.g1.g2.g3|100|TRUE|1/1/1949
String C|String m|String m.g1a.g2.g3|2|FALSE|2/14/2008
String C|String n|String n.g1.g2.g3|2|TRUE|1/1/1950
String C|String o|String o.g1.g2.g3|0|FALSE|1/1/1905
String C|String o|String o.g1a.g2a.g3|0|FALSE|3/1/1977
String C|String p|String p.g1.g2.g3|1|FALSE|4/1/2000
Rollup Need Example #1||||
Parent|Distinct Children Count|Child1|Child 2|….Child(# - last)
---|---|---|---|---|
String A|2|String Z|String Y||
String B|1|String w|||
String C|4|String m|String n|...String p|
Rollup Need Example #2||||
Parent|Calculated Value ->|Sum DataPoint1 if and only if: (DataPoint 2 = "T" OR (inclusive) DataPoint1 <>0 )AND where DataPoint3 >=1/1/1950
---|---|---|---|
A|5||||
B|0||||
C|5||||
我将假设您在Excel工作簿中的三张工作表上有三个ListObjects。
表1 (tbl父)
Item
A
B
C
表2 (tblChild)
Item Parent
z A
y A
w B
m C
n C
o C
p C
表3 (汤匙粒)
Grain Parent Data1 Data2 Data3
y.g1.g2.g3 y 0 TRUE 1/2/1970
w.g1.g2.g3 w 0 TRUE 9/5/1980
m.g1.g2.g3 m 100 TRUE 1/1/1949
n.g1.g2.g3 n 2 TRUE 1/1/1950
我将创建六个类模块，分别名为CParent、CParents、CChild、CChildren、CGrain、CGrains。
CParents
Private mcolParents As Collection
Private Sub Class_Initialize()
Set mcolParents = New Collection
End Sub
Private Sub Class_Terminate()
Set mcolParents = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
Set NewEnum = mcolParents.[_NewEnum]
End Property
Public Sub Add(clsParent As CParent)
If clsParent.ParentID = 0 Then
clsParent.ParentID = Me.Count + 1
End If
mcolParents.Add clsParent, CStr(clsParent.ParentID)
End Sub
Public Property Get Parent(vItem As Variant) As CParent
Set Parent = mcolParents.Item(vItem)
End Property
Public Property Get Count() As Long
Count = mcolParents.Count
End Property
Public Sub FillFromRange(ByRef rParents As Range, ByRef rChildren As Range, ByRef rGrains As Range)
Dim vaParents As Variant
Dim i As Long
Dim clsParent As CParent
vaParents = rParents.Value
For i = LBound(vaParents, 1) To UBound(vaParents, 1)
Set clsParent = New CParent
With clsParent
.Name_ = vaParents(i, 1)
End With
Me.Add clsParent
clsParent.Children.FillFromRange rChildren, clsParent.Name_, rGrains
Next i
End Sub
CParent
Private mlParentID As Long
Private msName_ As String
Private mclsChildren As CChildren
Public Property Set Children(ByVal clsChildren As CChildren): Set mclsChildren = clsChildren: End Property
Public Property Get Children() As CChildren: Set Children = mclsChildren: End Property
Public Property Let ParentID(ByVal lParentID As Long): mlParentID = lParentID: End Property
Public Property Get ParentID() As Long: ParentID = mlParentID: End Property
Public Property Let Name_(ByVal sName_ As String): msName_ = sName_: End Property
Public Property Get Name_() As String: Name_ = msName_: End Property
Private Sub Class_Initialize()
Set mclsChildren = New CChildren
End Sub
Private Sub Class_Terminate()
Set mclsChildren = Nothing
End Sub
克希尔德伦
Private mcolChildren As Collection
Private Sub Class_Initialize()
Set mcolChildren = New Collection
End Sub
Private Sub Class_Terminate()
Set mcolChildren = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
Set NewEnum = mcolChildren.[_NewEnum]
End Property
Public Sub Add(clsChild As CChild)
If clsChild.ChildID = 0 Then
clsChild.ChildID = Me.Count + 1
End If
mcolChildren.Add clsChild, CStr(clsChild.ChildID)
End Sub
Public Property Get Child(vItem As Variant) As CChild
Set Child = mcolChildren.Item(vItem)
End Property
Public Property Get Count() As Long
Count = mcolChildren.Count
End Property
Public Sub FillFromRange(ByRef rRng As Range, ByVal sParentName As String, ByRef rGrains As Range)
Dim vaValues As Variant
Dim i As Long
Dim clsChild As CChild
vaValues = rRng.Value
For i = LBound(vaValues, 1) To UBound(vaValues, 1)
If vaValues(i, 2) = sParentName Then
Set clsChild = New CChild
With clsChild
.Name_ = vaValues(i, 1)
End With
Me.Add clsChild
clsChild.Grains.FillFromRange rGrains, clsChild.Name_
End If
Next i
End Sub
克希尔德
Private mlChildID As Long
Private msName_ As String
Private mclsGrains As CGrains
Public Property Set Grains(ByVal clsGrains As CGrains): Set mclsGrains = clsGrains: End Property
Public Property Get Grains() As CGrains: Set Grains = mclsGrains: End Property
Public Property Let ChildID(ByVal lChildID As Long): mlChildID = lChildID: End Property
Public Property Get ChildID() As Long: ChildID = mlChildID: End Property
Public Property Let Name_(ByVal sName_ As String): msName_ = sName_: End Property
Public Property Get Name_() As String: Name_ = msName_: End Property
Private Sub Class_Initialize()
Set mclsGrains = New CGrains
End Sub
Private Sub Class_Terminate()
Set mclsGrains = Nothing
End Sub
CGrains
Private mcolGrains As Collection
Private Sub Class_Initialize()
Set mcolGrains = New Collection
End Sub
Private Sub Class_Terminate()
Set mcolGrains = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
Set NewEnum = mcolGrains.[_NewEnum]
End Property
Public Sub Add(clsGrain As CGrain)
If clsGrain.GrainID = 0 Then
clsGrain.GrainID = Me.Count + 1
End If
mcolGrains.Add clsGrain, CStr(clsGrain.GrainID)
End Sub
Public Property Get Grain(vItem As Variant) As CGrain
Set Grain = mcolGrains.Item(vItem)
End Property
Public Property Get Count() As Long
Count = mcolGrains.Count
End Property
Public Sub FillFromRange(ByRef rRng As Range, ByVal sChildName As String)
Dim vaValues As Variant
Dim i As Long
Dim clsGrain As CGrain
vaValues = rRng.Value
For i = LBound(vaValues, 1) To UBound(vaValues, 1)
If vaValues(i, 2) = sChildName Then
Set clsGrain = New CGrain
With clsGrain
.Data1 = vaValues(i, 3)
.Data2 = vaValues(i, 4)
.Data3 = vaValues(i, 5)
End With
Me.Add clsGrain
End If
Next i
End Sub
CGrain
Private mlGrainID As Long
Private mlData1 As Long
Private mbData2 As Boolean
Private mdtData3 As Date
Public Property Let GrainID(ByVal lGrainID As Long): mlGrainID = lGrainID: End Property
Public Property Get GrainID() As Long: GrainID = mlGrainID: End Property
Public Property Let Data1(ByVal lData1 As Long): mlData1 = lData1: End Property
Public Property Get Data1() As Long: Data1 = mlData1: End Property
Public Property Let Data2(ByVal bData2 As Boolean): mbData2 = bData2: End Property
Public Property Get Data2() As Boolean: Data2 = mbData2: End Property
Public Property Let Data3(ByVal dtData3 As Date): mdtData3 = dtData3: End Property
Public Property Get Data3() As Date: Data3 = mdtData3: End Property
到目前为止，所做的只是创建三个对象，在它们之间建立关系，并提供一种用Excel范围中的数据填充它们的方法。
关系是在单个对象类(而不是复数对象类)中建立的。CParent类具有一个包含CChildren集合类的属性。该父级的所有子级都存储在该类中。CChildren类包含一堆CChild对象。每个CChild对象都有一个属性CGrains，用于保存该子对象的所有粒度。这是很多设置，但回报即将到来。
接下来，在标准模块中，我想创建填充类的过程。
Public gclsParents As CParents
Public Sub Initialize()
Set gclsParents = New CParents
gclsParents.FillFromRange Sheet1.ListObjects(1).DataBodyRange, Sheet2.ListObjects(1).DataBodyRange, Sheet3.ListObjects(1).DataBodyRange
End Sub
我为顶级集合类创建了一个公共变量，这样它就不会超出范围。在Intialize中，我实例化了top集合类变量并调用FillFromRange方法。我把它传递给我的三个 Excel 表，代码填充了所有类。
现在，假设您要创建一个过程，列出所有父母、其子项计数及其子项列表。
Public Sub ListChildren()
Dim sh As Worksheet
Dim vaWrite As Variant
If gclsParents Is Nothing Then Initialize
Set sh = ThisWorkbook.Worksheets.Add
vaWrite = gclsParents.ChildListToRange
sh.Range("A1").Resize(UBound(vaWrite, 1), UBound(vaWrite, 2)).Value = vaWrite
End Sub
我的CParents实例(保存在gclsParents中)返回一个转储到新工作表的数组。输出看起来像
A 2 z,y
B 1 w
C 4 m,n,o,p
现在，您必须创建ChildListToRange方法。将此添加到CParents类
Public Property Get ChildListToRange() As Variant
Dim aReturn() As Variant
Dim clsParent As CParent
Dim lCnt As Long
ReDim aReturn(1 To Me.Count, 1 To 3)
For Each clsParent In Me
lCnt = lCnt + 1
aReturn(lCnt, 1) = clsParent.Name_
aReturn(lCnt, 2) = clsParent.Children.Count
aReturn(lCnt, 3) = clsParent.ChildListDelimited(",")
Next clsParent
ChildListToRange = aReturn
End Property
数组中的前两列已经定义，但我们需要在CParent类中创建一个ChildListDelimited属性。 将此添加到CParent
Public Property Get ChildListDelimited(ByVal sDelim As String) As String
Dim clsChild As CChild
Dim aReturn() As String
Dim lCnt As Long
ReDim aReturn(1 To Me.Children.Count)
For Each clsChild In Me.Children
lCnt = lCnt + 1
aReturn(lCnt) = clsChild.Name_
Next clsChild
ChildListDelimited = Join(aReturn, sDelim)
End Property
您提供一个分隔符，此属性返回由该分隔符分隔的所有子项的字符串。
仅此而已。您的第一份报告已完成。接下来，您要创建一个报表，以特定条件汇总Data1。在标准模块中创建此过程
Public Sub SummarizeValues()
Dim sh As Worksheet
Dim vaWrite As Variant
Dim clsToSum As CParents
If gclsParents Is Nothing Then Initialize
Set sh = ThisWorkbook.Worksheets.Add
Set clsToSum = gclsParents.FilterByData2(True).FilterByData3(DateSerial(1950, 1, 1), ">=")
vaWrite = clsToSum.SummarizeGrainValues
sh.Range("A1").Resize(UBound(vaWrite, 1), UBound(vaWrite, 2)).Value = vaWrite
End Sub
这看起来很像第一个过程，只是返回数组(要写入工作表)的CParents属性不同。此外，我们还会进行一些过滤。在第一个程序中，我们希望每个父母。现在我们只想要符合某些标准的父母。为此，请创建几个FilterBy属性。在CParents添加
Public Property Get FilterByData2(ByVal lData As Long) As CParents
Dim clsParent As CParent
Dim clsNewParent As CParent
Dim clsChild As CChild
Dim clsReturn As CParents
Set clsReturn = New CParents
For Each clsParent In Me
Set clsNewParent = New CParent
clsNewParent.Name_ = clsParent.Name_
Set clsNewParent.Children = clsParent.Children.FilterByData2(lData)
If clsNewParent.Children.Count > 0 Then
clsReturn.Add clsNewParent
End If
Next clsParent
Set FilterByData2 = clsReturn
End Property
这是一个常见的筛选属性。它需要一个大的CParents实例(在本例中gclsParents)并返回一个较小的实例。如果它找到符合条件的子项，则会将父级添加到返回类中。否则不会。但是你需要把这个标准传给孩子们。将此添加到CChildren类
Public Property Get FilterByData2(ByVal lData As Long) As CChildren
Dim clsChild As CChild
Dim clsNewChild As CChild
Dim clsGrain As CGrain
Dim clsReturn As CChildren
Set clsReturn = New CChildren
For Each clsChild In Me
Set clsNewChild = New CChild
clsNewChild.Name_ = clsChild.Name_
Set clsNewChild.Grains = clsChild.Grains.FilterByData2(lData)
If clsNewChild.Grains.Count > 0 Then
clsReturn.Add clsNewChild
End If
Next clsChild
Set FilterByData2 = clsReturn
End Property
并将其添加到CGrains类
Public Property Get FilterByData2(ByVal lData As Long) As CGrains
Dim clsGrain As CGrain
Dim clsReturn As CGrains
Set clsReturn = New CGrains
For Each clsGrain In Me
If clsGrain.Data2 = lData Then
clsReturn.Add clsGrain
End If
Next clsGrain
Set FilterByData2 = clsReturn
End Property
所有这些都返回一个CParents实例，其中只有最终具有 true 的Data2粒度的父实例。
从已经更小的CParents实例中，我们附加了另一个过滤器。将此添加到CParents
Public Property Get FilterByData3(ByVal dtData As Date, ByVal sComp As String) As CParents
Dim clsParent As CParent
Dim clsNewParent As CParent
Dim clsChild As CChild
Dim clsReturn As CParents
Set clsReturn = New CParents
For Each clsParent In Me
Set clsNewParent = New CParent
clsNewParent.Name_ = clsParent.Name_
Set clsNewParent.Children = clsParent.Children.FilterByData3(dtData, sComp)
If clsNewParent.Children.Count > 0 Then
clsReturn.Add clsNewParent
End If
Next clsParent
Set FilterByData3 = clsReturn
End Property
由于此筛选器使用不等式，因此它将变得更加复杂，我们将在一分钟内看到。现在，将其添加到CChildren
Public Property Get FilterByData3(ByVal dtData As Date, ByVal sComp As String) As CChildren
Dim clsChild As CChild
Dim clsNewChild As CChild
Dim clsGrain As CGrain
Dim clsReturn As CChildren
Set clsReturn = New CChildren
For Each clsChild In Me
Set clsNewChild = New CChild
clsNewChild.Name_ = clsChild.Name_
Set clsNewChild.Grains = clsChild.Grains.FilterByData3(dtData, sComp)
If clsNewChild.Grains.Count > 0 Then
clsReturn.Add clsNewChild
End If
Next clsChild
Set FilterByData3 = clsReturn
End Property
并将其添加到CGrains
Public Property Get FilterByData3(ByVal dtData As Date, ByVal sComp As String) As CGrains
Dim clsGrain As CGrain
Dim clsReturn As CGrains
Dim bAdd As Boolean
Set clsReturn = New CGrains
For Each clsGrain In Me
Select Case sComp
Case ">="
bAdd = clsGrain.Data3 >= dtData
Case ">"
bAdd = clsGrain.Data3 > dtData
Case "<"
bAdd = clsGrain.Data3 < dtData
Case "<="
bAdd = clsGrain.Data3 <= dtData
Case Else
bAdd = clsGrain.Data3 = dtData
End Select
If bAdd Then
clsReturn.Add clsGrain
End If
Next clsGrain
Set FilterByData3 = clsReturn
End Property
你可以在CGrains中看到，我必须用Select Case来弄清楚你想要什么不平等。但除此之外，它与第一个过滤器做同样的事情。
现在，您有一个变量clsToSum，它是一个仅包含所需父项的CParents实例。你已经完成了过滤，现在你所要做的就是总结一下。将此添加到CParents
Public Property Get SummarizeGrainValues() As Variant
Dim clsParent As CParent
Dim aReturn() As Variant
Dim lCnt As Long
ReDim aReturn(1 To Me.Count, 1 To 2)
For Each clsParent In Me
lCnt = lCnt + 1
aReturn(lCnt, 1) = clsParent.Name_
aReturn(lCnt, 2) = clsParent.SumData1
Next clsParent
SummarizeGrainValues = aReturn
End Property
现在您必须将SumData1添加到CParent
Public Property Get SumData1() As Long
Dim lReturn As Long
Dim clsChild As CChild
Dim clsGrain As CGrain
For Each clsChild In Me.Children
For Each clsGrain In clsChild.Grains
lReturn = lReturn + clsGrain.Data1
Next clsGrain
Next clsChild
SumData1 = lReturn
End Property
这循环遍历了所有孩子身上的所有谷物，并将它们加起来。 输出看起来像
A 0
B 0
C 2
现在基础结构已完成，您可以创建所需的任何方式的报告。只需设置所需的任何筛选器以及要报告的任何聚合属性。
我可能应该在顶部说这句话，但是如果你把这三个表放在一个适当的关系数据库中，你可以用两个相当短的SQL语句来完成所有这些工作。
如果要在工作簿中一起查看所有内容，请下载此 http://dailydoseofexcel.com/excel/ClassParentChildGrains.zip
自定义类将允许您创建层次结构，下面的示例类可帮助您入门。
父对象可以将子对象放在容器集合中，然后执行汇总计算以聚合集合中的所有对象。
假设您将子对象放置在集合中，您也可以将颗粒对象放置在其容器中，并创建层次结构作为套装。
Private pContainer As New Collection
Private pTitle As String
Private pValueToSum As Double
Public Property Get Container() As Collection
Set Container = pContainer
End Property
Public Property Let Container(value As Collection)
Set pContainer = value
End Property
Public Property Get GetTotals() As Double
Dim dbl As Double
Dim var As Variant
For Each var In Me.Container
dbl = dbl + var.ValueToSum
Next var
GetTotals = dbl
End Property