[已解决]恳请各位帮忙解决一下这个问题。。不胜感激！

kangkangtianxia · 发表于 2017-2-14 11:19

如左表所显示，A列、B列、F列为关键字进行统计，并分开统计单位不同的数据，在最终显示的总数中显示出来，如“结果”显示的那样。。谢谢!
数据有6000多条，麻烦各位高手用VBA帮忙解决一下，小弟不胜感激！

最佳答案

月排行榜 / 总排行榜

grf1973

2017-2-15 16:21

代码可以简化一点。

Sub test1()
Dim A, B
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set dd = CreateObject("scripting.dictionary")
A = Sheets(1).Range("a1").CurrentRegion
For i = 2 To UBound(A) '相同的产生单位归类
x2 = A(i, 1) '产生单位为key
d2(x2) = d2(x2) & "," & i
Next
With Sheets(2)
.Cells.Clear: .[H1] = "汇总"
.[a1].Resize(1, 7) = Split("危废产生单位,危废代码,危废名称,数量,单位,接收单位,地区", ",")
For Each x2 In d2.keys '对于相同的产生单位，汇总转换
xrr = Split(d2(x2), ",")
ReDim B(1 To UBound(xrr), 1 To UBound(A, 2))
n = 0: dd.RemoveAll
For k = 1 To UBound(xrr)
i = Val(xrr(k))
x1 = A(i, 1) & A(i, 2) & A(i, 3) & A(i, 6) '产生单位+代码+名称+接收单位为key
If Not d1.exists(x1) Then
n = n + 1
d1(x1) = n
For j = 1 To UBound(A, 2)
If j <> 4 Then B(n, j) = A(i, j)
Next
End If
B(d1(x1), 4) = B(d1(x1), 4) + A(i, 4)
sz = A(i, 4): dw = A(i, 5) '数值、单位
xx = x2 & dw '产生单位+计量单位为key
dd(xx) = CStr(Val(dd(xx)) + sz) & dw
Next
'输出
r = .[a65536].End(3).Row + 1
.Cells(r, 1).Resize(n, UBound(B, 2)) = B
.Cells(r, "H").Resize(n).Merge '合并H列单元格
.Cells(r, "H") = Join(dd.items, "+")
Next
.Activate
End With
End Sub

复制代码

跳转到最佳答案楼层

爱疯 · 发表于 2017-2-14 11:37

最好先通过现成工具汇总，比如数据透视表。
再看最终需求，确定下一步。

kangkangtianxia · 发表于 2017-2-14 11:46

爱疯发表于 2017-2-14 11:37
最好先通过现成工具汇总，比如数据透视表。
再看最终需求，确定下一步。

谢谢“爱疯”的回复！其实我也试过这个，但是显示的信息还是达不到我想要的结果，，所以就想通过其他的办法达到。麻烦帮忙看看可不可以通过vba实现。谢谢！

爱疯 · 发表于 2017-2-14 12:31

Sub test()
Dim A, B, d, i, j
Set d = CreateObject("scripting.dictionary")
A = Range("a1").CurrentRegion

'统计
For i = 2 To UBound(A)
      If Not d.exists(A(i, 1)) Then Set d(A(i, 1)) = CreateObject("scripting.dictionary")
      d(A(i, 1))(A(i, 5)) = d(A(i, 1))(A(i, 5)) + A(i, 4)
Next i

'转换
ReDim B(1 To d.Count, 1 To 2)
For i = 2 To UBound(A)
      If A(i - 1, 1) <> A(i, 1) Then
         j = j + 1
         B(j, 1) = A(i, 1)
         B(j, 2) = Dic2Str(d(A(i, 1)).KEYS, d(A(i, 1)).items)
      End If
Next i

'输出
Sheets(2).Select
Cells.Clear
Range("A1").Resize(UBound(B), UBound(B, 2)) = B
End Sub

'字典数据转字符串
Function Dic2Str(k, t) As String
Dim i
For i = 0 To UBound(t)
      Dic2Str = Dic2Str & "+" & t(i) & k(i)
Next i
Dic2Str = Mid(Dic2Str, 2)
End Function

麻烦给帮忙解决一下2.rar (12.09 KB, 下载次数: 3)