VBA跨表提取数据并取唯一值会进行汇总

深秋红叶2019

问题如上图片描述，谢谢大师们

liulang0808

去重求和，可以考虑使用字典的
楼主的号码去重，那么其他两项是不是跟号码也是唯一对应》？

深秋红叶2019

liulang0808 发表于 2020-1-29 17:01
去重求和，可以考虑使用字典的
楼主的号码去重，那么其他两项是不是跟号码也是唯一对应》？

是的老师，举个栗子，如果有几十或几百个学生，但是老板的号码都一样，那么就根据老板的电话来累计这些学生的学费进行汇总，前提是在报名登记里要有“返学费“，不知道我有没有表述清除

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    arr = Sheets("报名登记").UsedRange
    r = 0
    For j = 7 To UBound(arr)
        If arr(j, 12) = "返学费" Then
            If d.exists(arr(j, 9) & "") Then
                x = d(arr(j, 9) & "")
                arr(x, 4) = arr(x, 4) + arr(j, 11)
            Else
                r = r + 1
                d(arr(j, 9) & "") = r
                arr(r, 1) = arr(j, 6)
                arr(r, 2) = arr(j, 5)
                arr(r, 3) = arr(j, 9)
                arr(r, 4) = arr(j, 11)
            End If
        End If
    Next j
    If r > 0 Then [k3].Resize(r, 4) = arr
    Application.ScreenUpdating = True
End Sub

liulang0808

附件内容供参考。。。。。

深秋红叶2019

liulang0808 发表于 2020-1-29 17:31
附件内容供参考。。。。。

老师可以不用按钮实现效果吗，能实时更新会更好，还有左边那个是明细，代码怎么写呢，求教老师，谢谢

liulang0808

1. 
   
2. Private Sub Worksheet_Activate()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     arr = Sheets("报名登记").UsedRange
   
6.     brr = Sheets("报名登记").UsedRange
   
7.     r = 0
   
8.     br = 0
   
9.     For j = 7 To UBound(arr)
   
10.         If arr(j, 12) = "返学费" Then
    
11.             br = br + 1
    
12.             brr(br, 1) = Format(arr(j, 1), "yyyy/mm/dd")
    
13.             brr(br, 2) = arr(j, 9)
    
14.             brr(br, 3) = arr(j, 3)
    
15.             brr(br, 4) = arr(j, 4)
    
16.             brr(br, 5) = arr(j, 2)
    
17.             brr(br, 6) = arr(j, 5)
    
18.             brr(br, 7) = arr(j, 6)
    
19.             brr(br, 8) = arr(j, 10)
    
20.             brr(br, 9) = arr(j, 11)
    
21. 
    
22.             
    
23.             If d.exists(arr(j, 9) & "") Then
    
24.                 x = d(arr(j, 9) & "")
    
25.                 arr(x, 4) = arr(x, 4) + arr(j, 11)
    
26.             Else
    
27.                 r = r + 1
    
28.                 d(arr(j, 9) & "") = r
    
29.                 arr(r, 1) = arr(j, 6)
    
30.                 arr(r, 2) = arr(j, 5)
    
31.                 arr(r, 3) = arr(j, 9)
    
32.                 arr(r, 4) = arr(j, 11)
    
33.             End If
    
34.         End If
    
35.     Next j
    
36.     ActiveSheet.UsedRange.Offset(2).ClearContents
    
37.     If r > 0 Then
    
38.         [k3].Resize(r, 4) = arr
    
39.         [a3].Resize(br, 9) = brr
    
40.     End If
    
41.     Application.ScreenUpdating = True
    
42. End Sub
    

复制代码

liulang0808

表格事件，供参考。。。。。。

深秋红叶2019

liulang0808 发表于 2020-1-29 18:27

就是这个效果，谢谢老师