统计及提取不重复值的问题

goldenbee

统计及提取不重复值的问题，参考附件。
利用VBA程序怎么实现呢？
我VBA程序还是菜鸟，先谢谢各位了。

在线等待中。。。明天要给公司统计数据

zax010

Sub zz()
    Dim d, d1, arr
    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    arr = Sheet1.Range("A1").CurrentRegion
    For i = 2 To UBound(arr)
        d(arr(i, 2) & "," & arr(i, 1)) = d(arr(i, 2) & "," & arr(i, 1)) + arr(i, 3)
        d1(arr(i, 1)) = ""
    Next
    With Sheet2
        m = 2
        For Each k In d.keys
            .Range("C" & m).Resize(1, 2) = Split(k, ",")
            .Range("C" & m).Offset(0, 2) = d(k)
            m = m + 1
        Next
        .Range("C2:E22").Sort Key1:=.Range("C3"), Order1:=xlAscending, Header:=xlGuess
    End With
    Sheet3.Range("A2").Resize(d1.Count, 1) = Application.Transpose(d1.keys)
End Sub

zax010

附件：







Book1.rar (18.7 KB, 下载次数: 23)

2014-5-28 23:43 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim d As New Dictionary
   
3.   Dim d1 As New Dictionary
   
4.   Dim r%, i%
   
5.   With Worksheets("sheet1")
   
6.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
7.     arr = .Range("a2:c" & r)
   
8.   End With
   
9.   For i = 1 To UBound(arr)
   
10.     d1(arr(i, 1)) = ""
    
11.     If Not d.Exists(arr(i, 2)) Then
    
12.       Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
    
13.     End If
    
14.     d(arr(i, 2))(arr(i, 1)) = d(arr(i, 2))(arr(i, 1)) + arr(i, 3)
    
15.   Next
    
16.   With Worksheets("sheet2")
    
17.     .UsedRange.Offset(1, 0).ClearContents
    
18.     For Each aa In d.Keys
    
19.       r0 = .Cells(.Rows.Count, 4).End(xlUp).Row + 1
    
20.       .Cells(r0, 4).Resize(d(aa).Count, 1) = Application.Transpose(d(aa).Keys)
    
21.       .Cells(r0, 5).Resize(d(aa).Count, 1) = Application.Transpose(d(aa).Items)
    
22.       r1 = .Cells(.Rows.Count, 4).End(xlUp).Row
    
23.       .Range(.Cells(r0, 3), .Cells(r1, 3)) = aa
    
24.     Next
    
25.   End With
    
26.   With Worksheets("sheet3")
    
27.     .UsedRange.Offset(1, 0).ClearContents
    
28.     .Range("a2").Resize(d1.Count, 1) = Application.Transpose(d1.Keys)
    
29.   End With
    
30. End Sub
    

复制代码

chxw68

详见附件。

goldenbee

这么快得到回复，谢谢楼上的几位了。

goldenbee

不好意识，不用按钮，想自动执行的话，加那些代码呢？