修改汇总代码

lufabao7788

Sub test()

Dim arr()
Dim x, y, k, m
Dim d
With Sheets("第四次活动会员缴费表")
Set d = CreateObject("scripting.dictionary")
arr = Range("A8").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 16)
For x = 3 To UBound(arr)

    If d.Exists(arr(x, 13)) Then

        m = d(arr(x, 13))
        brr(m, 3) = arr(x, 3) + brr(m, 3)
        brr(m, 4) = arr(x, 4) + brr(m, 4)
    Else
        k = k + 1
        d(arr(x, 1)) = k
        For y = 1 To 16
            brr(k, y) = arr(x, y)
        Next y
    End If

Next x
End With

With Sheets("单条件多列汇总")
.Range("a8").Resize(UBound(arr), 16) = brr
End With
End Sub

lsc900707

lufabao7788 发表于 2018-8-22 13:12
不好意思lsc900707老师，我的水平太差，费了半天劲才贴上一个图片。
请帮忙修改，把原来的（单条件多列 ...

表头自己弄一下，代码修改如下：

1. Sub gj23w98()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     With Sheets("第四次活动会员缴费表")
   
4.         r = .Cells(.Rows.Count, 13).End(3).Row
   
5.         arr = .Range("a8:p" & r)
   
6.     End With
   
7.     ReDim brr(1 To UBound(arr), 1 To 6)
   
8.     For x = 1 To UBound(arr)
   
9.         s = arr(x, 13)
   
10.         If d(s) = "" Then
    
11.             k = k + 1: d(s) = k
    
12.             brr(k, 1) = s
    
13.             brr(k, 2) = arr(x, 11)
    
14.             brr(k, 3) = arr(x, 7)
    
15.             For j = 4 To 6
    
16.                 brr(k, j) = arr(x, j + 10)
    
17.             Next
    
18.         Else
    
19.             brr(d(s), 2) = arr(x, 11) + brr(d(s), 2)
    
20.             brr(d(s), 3) = arr(x, 7) + brr(d(s), 3)
    
21.             For j = 4 To 5
    
22.                 brr(d(s), j) = arr(x, j + 10) + brr(d(s), j)
    
23.             Next
    
24.             brr(d(s), 6) = brr(d(s), 3) - brr(d(s), 4) - brr(d(s), 5)
    
25.         End If
    
26.     Next
    
27.     With Sheets("单条件多列汇总")
    
28.         .[a5].Resize(k, 6) = brr
    
29.     End With
    
30. End Sub
    

复制代码

lsc900707

brr(m, 3) = arr(x, 3) + brr(m, 3)
brr(m, 4) = arr(x, 4) + brr(m, 4)
这两个不是你要求和的列呀，改成你要求的这几列看看。

lufabao7788

修改过了，还是不能把每个推荐人分别汇总。

lsc900707

lufabao7788 发表于 2018-8-21 22:36
修改过了，还是不能把每个推荐人分别汇总。

学会给帮助者“评分”，很多问题迎刃而解！

lsc900707

lufabao7788 发表于 2018-8-21 22:36
修改过了，还是不能把每个推荐人分别汇总。

Sub test()
    Set d = CreateObject("scripting.dictionary")
    With Sheets("第四次活动会员缴费表")
        r = .Cells(.Rows.Count, 13).End(3).Row
        arr = .Range("a8:p" & r)
    End With
    ReDim brr(1 To UBound(arr), 1 To 16)
    For x = 1 To UBound(arr)
        If Not d.Exists(arr(x, 13)) Then
            k = k + 1
            d(arr(x, 13)) = k
            For y = 1 To 16
                brr(k, y) = arr(x, y)
            Next
        Else
            m = m + 1
            m = d(arr(x, 13))
            brr(m, 7) = arr(x, 7) + brr(m, 7)
            brr(m, 11) = arr(x, 11) + brr(m, 11)
            For j = 14 To 15
                brr(m, j) = arr(x, j) + brr(m, j)
            Next
            brr(m, 16) = brr(m, 7) - brr(m, 14) - brr(m, 15)
    End If
Next
With Sheets("单条件多列汇总")
.Range("a8").Resize(k, 16) = brr
End With
End Sub

lufabao7788

拜读完了，我对每一段都进行了详细的研究，非常好。
非常感谢lsc900707
再请帮一下忙，保存时把（推荐人）的姓名保存到第一列，谢谢！

lufabao7788

lsc900707 发表于 2018-8-22 05:39
Sub test()
    Set d = CreateObject("scripting.dictionary")
    With Sheets("第四次活动会员缴费 ...

lsc900707老师起那么早

lsc900707

lufabao7788 发表于 2018-8-22 11:25
拜读完了，我对每一段都进行了详细的研究，非常好。
非常感谢lsc900707
再请帮一下忙，保存时把（推荐人 ...

其它列呢，要不要变？

lufabao7788

lsc900707 发表于 2018-8-22 12:16
其它列呢，要不要变？

lufabao7788