[已解决]求助VBA程序-进行数据统计

新月妹妹 · 发表于 2012-1-30 17:11

这个是我同学问的问题，我搞不定了，请大侠们解决一下。

具体要求见附件：

问题-汇总统计.rar (6.87 KB, 下载次数: 12)

2012-1-30 17:10 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

sunjing-zxl

2012-1-30 17:22

本帖最后由 sunjing-zxl 于 2012-1-30 17:24 编辑

Sub 统计()
Dim d As New Dictionary
Dim d1 As New Dictionary
Dim arr1, arr2, arr3, arr4
Dim i As Long, j As Long
arr1 = Range("B2:D" & [B65536].End(xlUp).Row)
For i = 1 To UBound(arr1)
If Len(arr1(i, 1)) Then '如果项目（既B列）不为空则：
If Not d1.Exists(arr1(i, 2)) Then
'对工程（即C列）进行字典定位
d1(arr1(i, 2)) = d1.Count + 1
End If
If Not d.Exists(arr1(i, 1)) Then
d.Add arr1(i, 1), 1 '将项目（既B列）装入父字典
Set d(arr1(i, 1)) = New Dictionary '同时定义每个父字典元素的子字典
End If
If d(arr1(i, 1)).Exists(arr1(i, 2)) Then
'如果子字典未赋值，则将工程值(即C列)作为其key值，D列(金额)值作为其item值进行赋值；否则将item进行累加
d(arr1(i, 1))(arr1(i, 2)) = d(arr1(i, 1))(arr1(i, 2)) + arr1(i, 3)
Else
d(arr1(i, 1)).Add arr1(i, 2), arr1(i, 3)
End If
End If
Next i
'字典数据处理
If d.Count > 0 Then '如果父字典个数大于0
arr1 = d.Keys
arr2 = d1.Keys
ReDim arr3(1 To UBound(arr1) + 2, 1 To UBound(arr2) + 2) '重定义数组大小，以备生成"汇总分析表"数据
For i = 0 To UBound(arr2)
arr3(1, i + 2) = arr2(i)
Next i
For i = 0 To UBound(arr1)
arr3(i + 2, 1) = arr1(i)
arr4 = d(arr1(i)).Keys
For j = 0 To UBound(arr4)
arr3(i + 2, d1(arr4(j)) + 1) = d(arr1(i))(arr4(j))
Next j
Set d(arr1(i)) = Nothing
Next i
With Sheets("汇总分析表")
m = .Range("B2").End(xlDown).Row
n = .Range("C1").End(xlToRight).Column
.Range(.Cells(2, 1), .Cells(m, n)).ClearContents '清除数据区域
.Range("B1").Resize(UBound(arr3), UBound(arr3, 2)) = arr3 '拷贝数组到"汇总分析表"中
End With
End If
Set d = Nothing
Set d1 = Nothing
MsgBox "汇总完成"
End Sub

复制代码

问题-汇总统计-sunjing.rar (12.73 KB, 下载次数: 45)

sunjing-zxl · 发表于 2012-1-30 17:14

哈哈，我最近就在练习这样的题。
已经不难解决了。
最多10分钟给你答案

sunjing-zxl · 发表于 2012-1-30 17:22

这个最佳答案由 sunjing-zxl 给出，感谢 sunjing-zxl 的回答。

单击隐藏图章

本帖最后由 sunjing-zxl 于 2012-1-30 17:24 编辑

Sub 统计()
Dim d As New Dictionary
Dim d1 As New Dictionary
Dim arr1, arr2, arr3, arr4
Dim i As Long, j As Long
arr1 = Range("B2:D" & [B65536].End(xlUp).Row)
For i = 1 To UBound(arr1)
If Len(arr1(i, 1)) Then '如果项目（既B列）不为空则：
If Not d1.Exists(arr1(i, 2)) Then
'对工程（即C列）进行字典定位
d1(arr1(i, 2)) = d1.Count + 1
End If
If Not d.Exists(arr1(i, 1)) Then
d.Add arr1(i, 1), 1 '将项目（既B列）装入父字典
Set d(arr1(i, 1)) = New Dictionary '同时定义每个父字典元素的子字典
End If
If d(arr1(i, 1)).Exists(arr1(i, 2)) Then
'如果子字典未赋值，则将工程值(即C列)作为其key值，D列(金额)值作为其item值进行赋值；否则将item进行累加
d(arr1(i, 1))(arr1(i, 2)) = d(arr1(i, 1))(arr1(i, 2)) + arr1(i, 3)
Else
d(arr1(i, 1)).Add arr1(i, 2), arr1(i, 3)
End If
End If
Next i
'字典数据处理
If d.Count > 0 Then '如果父字典个数大于0
arr1 = d.Keys
arr2 = d1.Keys
ReDim arr3(1 To UBound(arr1) + 2, 1 To UBound(arr2) + 2) '重定义数组大小，以备生成"汇总分析表"数据
For i = 0 To UBound(arr2)
arr3(1, i + 2) = arr2(i)
Next i
For i = 0 To UBound(arr1)
arr3(i + 2, 1) = arr1(i)
arr4 = d(arr1(i)).Keys
For j = 0 To UBound(arr4)
arr3(i + 2, d1(arr4(j)) + 1) = d(arr1(i))(arr4(j))
Next j
Set d(arr1(i)) = Nothing
Next i
With Sheets("汇总分析表")
m = .Range("B2").End(xlDown).Row
n = .Range("C1").End(xlToRight).Column
.Range(.Cells(2, 1), .Cells(m, n)).ClearContents '清除数据区域
.Range("B1").Resize(UBound(arr3), UBound(arr3, 2)) = arr3 '拷贝数组到"汇总分析表"中
End With
End If
Set d = Nothing
Set d1 = Nothing
MsgBox "汇总完成"
End Sub

复制代码

问题-汇总统计-sunjing.rar (12.73 KB, 下载次数: 45)

新月妹妹 · 发表于 2012-1-30 17:55

高手，谢谢了

chendaren · 发表于 2012-1-31 20:23

能干人啊

chendaren · 发表于 2012-1-31 20:31

		自动登录	找回密码
密码			注册