VB方法 汇总求和

LWL666888

    列位大侠：求助 用VB方法 汇总求和。前次求助中的附件表述不清，现修改。麻烦列位，能帮助看看！

zax010

Sub zz()
    Dim d, ar, br, m%
    Set d = CreateObject("Scripting.Dictionary")
    ar = Range("B4:G" & [a65536].End(3).Row)
    ReDim br(1 To UBound(ar), 1 To 4)
    For i = 1 To UBound(ar)
        s = ar(i, 1) & ar(i, 2) & ar(i, 5)
        If d(s) = "" Then
            m = m + 1: d(s) = m
            br(m, 1) = ar(i, 1): br(m, 2) = ar(i, 2): br(m, 3) = ar(i, 5): br(m, 4) = ar(i, 6)
        Else
            br(d(s), 4) = br(d(s), 4) + ar(i, 6)
        End If
    Next
    [o4].Resize(m, 4) = br
End Sub

梧月书声

使用数据透视表最为便捷 请测试
模板2.zip (499.69 KB, 下载次数: 21)

2016-7-24 19:19 上传

点击文件名下载附件

amzxfgh9632

1. Sub 汇总()
   
2. Range("O4:R50").ClearContents
   
3. Dim i%, k%, arr(), s$
   
4. Dim d As Object
   
5. Set d = CreateObject("scripting.dictionary")
   
6. arr = Range("A1").CurrentRegion
   
7. For i = 4 To UBound(arr)
   
8.     s = arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 6)
   
9.     d(s) = d(s) + arr(i, 7)
   
10. Next
    
11. Range("O4").Resize(d.Count) = Application.Transpose(d.keys)
    
12. Range("R4").Resize(d.Count) = Application.Transpose(d.items)
    
13. Application.DisplayAlerts = False
    
14. Range("O4").Resize(d.Count).TextToColumns DataType:=xlDelimited, comma:=True
    
15. Application.DisplayAlerts = True
    
16. End Sub

复制代码

zax010

>>>>>>>>>>>>>>>>>>>>>>>>>>>


模板2.rar (453.28 KB, 下载次数: 92)

2016-7-24 20:15 上传

点击文件名下载附件

LWL666888

zax010 发表于 2016-7-24 20:12
Sub zz()
    Dim d, ar, br, m%
    Set d = CreateObject("Scripting.Dictionary")

zax010 先谢谢!

LWL666888

梧月书声 发表于 2016-7-24 20:14
使用数据透视表最为便捷 请测试

梧月书声，先谢谢关注。最近接触VB较多，想多学学

LWL666888

amzxfgh9632 发表于 2016-7-24 20:15

amzxfgh9632 先谢谢了，我来试试

182197315

Sub 汇总()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim i%, k%, x%, st$, arr(), brr(1 To 500, 1 To 4)
arr = Range("A4:G" & [A65536].End(3).Row).Value
For i = 1 To UBound(arr)
    st = arr(i, 2) & "-" & arr(i, 3) & "-" & arr(i, 6)
    If Not d.exists(st) Then
        k = k + 1
        d(st) = k
        brr(k, 1) = arr(i, 2)
        brr(k, 2) = arr(i, 3)
        brr(k, 3) = arr(i, 6)
        brr(k, 4) = arr(i, 7)
    Else
        x = d(st)
        brr(x, 4) = brr(x, 4) + arr(i, 7)
    End If
Next
Range("O4").Resize(k, 4) = brr
End Sub

LWL666888

182197315 发表于 2016-7-24 20:43
Sub 汇总()
Dim d As Object
Set d = CreateObject("scripting.dictionary")

182197315大侠  先谢谢了