[已解决]请求不重复字段的数字累加,然后放到行或列

zzk386

请求代码:把不重复字段的数字累加,然后放到行或列

最佳答案

月排行榜 / 总排行榜

安贤

2011-10-4 11:42

Sub aa()
Dim x As Integer
Dim d As Object
Dim a
Dim b

Set d = CreateObject("Scripting.Dictionary")
For x = 1 To Range("A65536").End(xlUp).Row
    If Cells(x, 2) <> "" Then
        d(Cells(x, 2).Value) = Cells(x, 1).Value + d(Cells(x, 2).Value)
    End If
Next x
a = d.Items
b = d.keys
For x = 0 To d.Count - 1
Sheets("sheet2").Cells(x + 1, 1) = b(x)
Sheets("sheet2").Cells(x + 1, 2) = a(x)

Sheets("sheet3").Cells(1, x + 1) = b(x)
Sheets("sheet3").Cells(2, x + 1) = a(x)


Next x
End Sub

跳转到最佳答案楼层

那么的帅

回复 zzk386 的帖子

看不懂原始数据
最好楼主提供下结果数据是什么样子的。

fjmxwrs

回复 zzk386 的帖子

1. Sub 按钮1_Click()
   
2. Dim arr, obj_d As Object, x&
   
3. Set obj_d = CreateObject("scripting.dictionary")
   
4. With Sheet1
   
5. arr = .Range("A2:B" & .Range("A65536").End(xlUp).Row)
   
6. End With
   
7. For x = 1 To UBound(arr)
   
8. If arr(x, 2) <> "" Then
   
9. obj_d(arr(x, 2)) = obj_d(arr(x, 2)) + arr(x, 1)
   
10. End If
    
11. Next x
    
12. With Sheet2
    
13. .Range("A2:B65536").ClearContents
    
14. .Range("A2").Resize(obj_d.Count, 1) = Application.Transpose(obj_d.keys)
    
15. .Range("B2").Resize(obj_d.Count, 1) = Application.Transpose(obj_d.items)
    
16. .Select
    
17. End With
    
18. End Sub

复制代码

不重复字段的数字累加,然后放到行或列.zip (10.99 KB, 下载次数: 12)

2011-10-4 11:08 上传

点击文件名下载附件
点按钮就统计好了

安贤

Sub aa()
Dim x As Integer
Dim d As Object
Dim a
Dim b

Set d = CreateObject("Scripting.Dictionary")
For x = 1 To Range("A65536").End(xlUp).Row
    If Cells(x, 2) <> "" Then
        d(Cells(x, 2).Value) = Cells(x, 1).Value + d(Cells(x, 2).Value)
    End If
Next x
a = d.Items
b = d.keys
For x = 0 To d.Count - 1
Sheets("sheet2").Cells(x + 1, 1) = b(x)
Sheets("sheet2").Cells(x + 1, 2) = a(x)

Sheets("sheet3").Cells(1, x + 1) = b(x)
Sheets("sheet3").Cells(2, x + 1) = a(x)


Next x
End Sub

安贤

放入sheet1代码窗口