[已解决]还有一事，恳请各位再帮忙一下。。vba

kangkangtianxia

详细见附件。。将多列数据用vba进行统计。。谢谢！

最佳答案

月排行榜 / 总排行榜

grf1973

2017-2-16 14:37

1. Sub test2()
   
2.     Dim A
   
3.     Set d1 = CreateObject("scripting.dictionary")
   
4.     Set dd = CreateObject("scripting.dictionary")
   
5.     A = Sheets(1).Range("a1").CurrentRegion
   
6.     ReDim B(1 To UBound(A), 1 To 4)
   
7.     For i = 2 To UBound(A)   '相同的产生单位归类
   
8.         x1 = A(i, 1)     '产生单位为key
   
9.         sz = A(i, 4): dw = A(i, 5) '数值、单位
   
10.         If Not d1.exists(x1) Then
    
11.             n = n + 1
    
12.             d1(x1) = n
    
13.             B(n, 1) = x1
    
14.             B(n, 3) = A(i, 6)
    
15.             B(n, 4) = A(i, 7)
    
16.         End If
    
17.         p = d1(x1)
    
18.         B(p, 2) = B(p, 2) & "," & sz & "-" & dw
    
19.         If InStr(B(p, 3), A(i, 6)) = 0 Then B(p, 3) = B(p, 3) & "、" & A(i, 6)
    
20.         If InStr(B(p, 4), A(i, 7)) = 0 Then B(p, 4) = B(p, 4) & "、" & A(i, 7)
    
21.     Next
    
22.    
    
23.     For i = 1 To n   '计算数值+单位
    
24.         xrr = Split(B(i, 2), ",")
    
25.         For k = 1 To UBound(xrr)
    
26.             sz = Val(xrr(k)): dw = Split(xrr(k), "-")(1) '数值、单位
    
27.             dd(dw) = CStr(Val(dd(dw)) + sz) & dw
    
28.         Next
    
29.         B(i, 2) = Join(dd.items, "+")
    
30.         dd.RemoveAll
    
31.     Next
    
32.    
    
33.     With Sheets(2)   '输出
    
34.         .Cells.Clear
    
35.         .[a1].Resize(1, 4) = Split("危废产生单位,数量,接收单位,地区", ",")
    
36.         .[a2].Resize(n, 4) = B
    
37.         .Activate
    
38.     End With
    
39. End Sub

复制代码

跳转到最佳答案楼层

grf1973

1. Sub test2()
   
2.     Dim A
   
3.     Set d1 = CreateObject("scripting.dictionary")
   
4.     Set dd = CreateObject("scripting.dictionary")
   
5.     A = Sheets(1).Range("a1").CurrentRegion
   
6.     ReDim B(1 To UBound(A), 1 To 4)
   
7.     For i = 2 To UBound(A)   '相同的产生单位归类
   
8.         x1 = A(i, 1)     '产生单位为key
   
9.         sz = A(i, 4): dw = A(i, 5) '数值、单位
   
10.         If Not d1.exists(x1) Then
    
11.             n = n + 1
    
12.             d1(x1) = n
    
13.             B(n, 1) = x1
    
14.             B(n, 3) = A(i, 6)
    
15.             B(n, 4) = A(i, 7)
    
16.         End If
    
17.         p = d1(x1)
    
18.         B(p, 2) = B(p, 2) & "," & sz & "-" & dw
    
19.         If InStr(B(p, 3), A(i, 6)) = 0 Then B(p, 3) = B(p, 3) & "、" & A(i, 6)
    
20.         If InStr(B(p, 4), A(i, 7)) = 0 Then B(p, 4) = B(p, 4) & "、" & A(i, 7)
    
21.     Next
    
22.    
    
23.     For i = 1 To n   '计算数值+单位
    
24.         xrr = Split(B(i, 2), ",")
    
25.         For k = 1 To UBound(xrr)
    
26.             sz = Val(xrr(k)): dw = Split(xrr(k), "-")(1) '数值、单位
    
27.             dd(dw) = CStr(Val(dd(dw)) + sz) & dw
    
28.         Next
    
29.         B(i, 2) = Join(dd.items, "+")
    
30.         dd.RemoveAll
    
31.     Next
    
32.    
    
33.     With Sheets(2)   '输出
    
34.         .Cells.Clear
    
35.         .[a1].Resize(1, 4) = Split("危废产生单位,数量,接收单位,地区", ",")
    
36.         .[a2].Resize(n, 4) = B
    
37.         .Activate
    
38.     End With
    
39. End Sub

复制代码

雄鹰2013

Sub 统计()
Dim arr, brr
Set d = CreateObject("scripting.dictionary") '公司名
Set d2 = CreateObject("scripting.dictionary") '数量
Set d3 = CreateObject("scripting.dictionary") '接收单位
arr = Sheets("数据源").Range("a1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 4)
For i = 2 To UBound(arr)
     y = arr(i, 1) & "," & arr(i, 7)
     d(y) = d(y) & "," & i '将公司和行号一一对应
Next i
For Each k In d.keys
     ar = Split(d(k), ",")
     For i = 1 To UBound(ar)
         x = ar(i) '公司对应在行号
         zf = arr(x, 1) & arr(x, 5) '接收公司和单位合并
         s = arr(x, 4): dw = arr(x, 5)
         d2(zf) = CStr(Val(d2(zf)) + s) & dw '注意这句
         zf2 = arr(x, 1) & arr(x, 6) '注意这句
         d3(zf2) = arr(x, 6)
     Next i
     br = d3.items
     n = n + 1
     brr(n, 1) = Split(k, ",")(0)
     brr(n, 2) = Join(d2.items, "+")
     brr(n, 3) = Join(d3.items, "、")
     brr(n, 4) = arr(ar(1), 7)
     d2.RemoveAll: d3.RemoveAll
Next k
With Sheets("目标结果")
      .Cells.Clear
      .Range("a1").Resize(1, 4) = Array("危废产生单位", "数量", "接收单位", "地区")
      .Range("a2").Resize(n, 4) = brr
      .Columns("A:D").AutoFit
      .Activate
End With
End Sub

雄鹰2013

Sub 统计2() '雄鹰
Dim arr, brr
Set d = CreateObject("scripting.dictionary") '公司名
Set d2 = CreateObject("scripting.dictionary") '数量
Set d3 = CreateObject("scripting.dictionary") '接收单位
Set d4 = CreateObject("scripting.dictionary") '地区
arr = Sheets("数据源").Range("a1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 4)
For i = 2 To UBound(arr)
     y = arr(i, 1)
     d(y) = d(y) & "," & i '将公司和行号一一对应
Next i
For Each k In d.keys
     ar = Split(d(k), ",")
     For i = 1 To UBound(ar)
         x = ar(i) '公司对应在行号
         zf = arr(x, 1) & arr(x, 5) '接收公司和单位合并
         s = arr(x, 4): dw = arr(x, 5)
         d2(zf) = CStr(Val(d2(zf)) + s) & dw '注意这句
         zf2 = arr(x, 1) & arr(x, 6) '注意这句
         d3(zf2) = arr(x, 6)
         zf3 = arr(x, 1) & arr(x, 7) '注意这句
         d4(zf3) = arr(x, 7)
     Next i
     n = n + 1
     brr(n, 1) = k
     brr(n, 2) = Join(d2.items, "+")
     brr(n, 3) = Join(d3.items, "、")
     brr(n, 4) = Join(d4.items, "、")
     d2.RemoveAll: d3.RemoveAll: d4.RemoveAll
Next k
With Sheets("目标结果")
      .Cells.Clear
      .Range("a1").Resize(1, 4) = Array("危废产生单位", "数量", "接收单位", "地区")
      .Range("a2").Resize(n, 4) = brr
      .Columns("A:D").AutoFit
      .Activate
End With
End Sub