去重求和后将结果替换指定位置的数值

wowo000

尊敬的各位老师：俺重新上传了附件，里面有截图效果，恳请帮忙，谢谢！

wowo000

尊敬的各位老师：俺要的截图效果，恳请帮忙，谢谢！

ykcbf1100

wowo000 发表于 2024-12-16 08:38
尊敬的草爷，就是将主单号对应的金额去重求和后，再把“和”替换它所对应的单元格里数值，劳烦了，谢谢！

是这意思？

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.12.16
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     r = Cells(Rows.Count, 3).End(3).Row
   
6.     arr = [a1].Resize(r, 16)
   
7.     For i = 5 To UBound(arr)
   
8.         s = arr(i, 16)
   
9.         d(s) = d(s) + arr(i, 7)
   
10.         d1(s) = d1(s) + 1
    
11.     Next
    
12.     For i = 5 To UBound(arr)
    
13.         s = arr(i, 16)
    
14.         If d1(s) > 1 Then
    
15.             m = Application.Sum(Cells(i, 8).Resize(, 4))
    
16.             If m = 0 Then
    
17.                 arr(i, 7) = ""
    
18.             Else
    
19.                 arr(i, 7) = d(s)
    
20.             End If
    
21.         End If
    
22.     Next
    
23.     [g1].Resize(r, 1) = Application.Index(arr, 0, 7)
    
24.     Set d = Nothing
    
25.     Set d1 = Nothing
    
26.     Application.ScreenUpdating = True
    
27.     MsgBox "OK！"
    
28. End Sub
    

复制代码

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("sheet1")
   
7.         .AutoFilterMode = False
   
8.         r = .Cells(.Rows.Count, 16).End(xlUp).Row
   
9.         arr = .Range("a5:p" & r)
   
10.         For i = 1 To UBound(arr)
    
11.             d(arr(i, 16)) = d(arr(i, 16)) + arr(i, 7)
    
12.         Next
    
13.         For i = 1 To UBound(arr)
    
14.             If d.exists(arr(i, 16)) Then
    
15.                 For j = 8 To 11
    
16.                     If Len(arr(i, j)) <> 0 And arr(i, j) <> 0 Then
    
17.                         arr(i, j) = d(arr(i, 16))
    
18.                     End If
    
19.                 Next
    
20.             End If
    
21.         Next
    
22.         .Range("a5:p" & r) = arr
    
23.     End With
    
24. End Sub
    

复制代码

chxw68

详见附件。

wowo000

chxw68 发表于 2024-12-16 09:08
详见附件。

衷心感谢您！太完美了！尊敬的chxw68老师！

wowo000

ykcbf1100 发表于 2024-12-16 09:01
是这意思？

尊敬的草爷：您的反了，不是替换金额栏，是替换H列到K列的费用栏，劳烦再给整整，多谢！

ykcbf1100

wowo000 发表于 2024-12-16 09:21
尊敬的草爷：您的反了，不是替换金额栏，是替换H列到K列的费用栏，劳烦再给整整，多谢！

改一下，看是不是你要的结果。

wowo000

ykcbf1100 发表于 2024-12-16 09:43
改一下，看是不是你要的结果。

衷心感谢您的帮助！抱歉还未达到俺的要求，谢谢您！草爷。十六楼chxw68老师的代码完全符合俺的要求。