[已解决]汇总相关数据

billyzhang0609 · 发表于 2016-7-26 16:26

简化模型如附件，数据量超大

最佳答案

scl5801

2016-7-26 19:45

billyzhang0609 发表于 2016-7-26 16:29
附件和截图如下：

Sub hebing()
Dim arr, brr, i, j, d
Set d = CreateObject("scripting.dictionary")
arr = [a2:c16]
For i = 1 To UBound(arr)
   d(arr(i, 1)) = ""
Next
k = d.keys
ReDim brr(1 To UBound(k) + 1, 1 To 3)
For i = 1 To UBound(k) + 1
   For j = 1 To UBound(arr)
      If k(i - 1) = arr(j, 1) Then
         brr(i, 1) = arr(j, 1)
         brr(i, 2) = brr(i, 2) + arr(j, 2)
         brr(i, 3) = brr(i, 3) + arr(j, 3)
      End If
   Next j
Next i
[a23].Resize(i - 1, 3) = brr
End Sub

跳转到最佳答案楼层

billyzhang0609 · 发表于 2016-7-26 16:29

附件和截图如下：

scl5801 · 发表于 2016-7-26 19:45

这个最佳答案由 scl5801 给出，感谢 scl5801 的回答。

单击隐藏图章

billyzhang0609 发表于 2016-7-26 16:29
附件和截图如下：

Sub hebing()
Dim arr, brr, i, j, d
Set d = CreateObject("scripting.dictionary")
arr = [a2:c16]
For i = 1 To UBound(arr)
   d(arr(i, 1)) = ""
Next
k = d.keys
ReDim brr(1 To UBound(k) + 1, 1 To 3)
For i = 1 To UBound(k) + 1
   For j = 1 To UBound(arr)
      If k(i - 1) = arr(j, 1) Then
         brr(i, 1) = arr(j, 1)
         brr(i, 2) = brr(i, 2) + arr(j, 2)
         brr(i, 3) = brr(i, 3) + arr(j, 3)
      End If
   Next j
Next i
[a23].Resize(i - 1, 3) = brr
End Sub

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