条件求和，谢谢！

a18b88 · 发表于 2023-3-6 17:34

详见附件：

条件求和.rar (38.81 KB, 下载次数: 11)

chxw68 · 发表于 2023-3-6 20:37

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With Worksheets("此表求和")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(3, .Columns.Count).End(xlToLeft).Column
arr = .Range("a2").Resize(1, c)
For j = 2 To UBound(arr, 2)
d1(arr(1, j)) = j
Next
End With
ls = c
With Worksheets("录入")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a4:z" & r)
End With
For i = 1 To UBound(arr)
If d1.exists(arr(i, 11)) Then
n = d1(arr(i, 11))
If Not d.exists(arr(i, 20)) Then
ReDim brr(1 To ls)
brr(1) = arr(i, 20)
Else
brr = d(arr(i, 20))
End If
brr(n) = brr(n) + arr(i, 16)
brr(n + 1) = brr(n + 1) + arr(i, 19)
brr(2) = brr(2) + arr(i, 16)
brr(3) = brr(3) + arr(i, 19)
d(arr(i, 20)) = brr
End If
Next
With Worksheets("此表求和")
.Range("a4:bk51").ClearContents
.Range("a4").Resize(d.Count, ls) = Application.Transpose(Application.Transpose(d.items))
End With
End Sub

复制代码

chxw68 · 发表于 2023-3-6 20:38

详见附件。

洋务德雷 · 发表于 2023-3-6 21:32

看了你的表格，感觉和凌乱。如果把问题解决的比较好。只是靠vba是不行的。还需要把你的数据表格好好整理一番。加我好友，我们可以好好交流一下。

sxbjzjf110 · 发表于 2023-3-6 22:12

a18b88 · 发表于 2023-3-7 05:50

sxbjzjf110 发表于 2023-3-6 22:12

万分感谢您的帮助，谢谢！

a18b88 · 发表于 2023-3-7 10:09

sxbjzjf110 发表于 2023-3-6 22:12

业务员姓名自动增加问题，谢谢！想看附件：

条件求和1.rar (46.58 KB, 下载次数: 5)

tanglf188 · 发表于 2023-3-7 11:25

sxbjzjf110 · 发表于 2023-3-7 11:47

请测试。。。。。

sxbjzjf110 · 发表于 2023-3-7 11:56

修改了一下，删除也跟着自动变化。

		自动登录	找回密码
密码			免费注册

[求助] 条件求和，谢谢！