求代码，思路理清楚了

张起灵1

liulang0808

Sub 按钮1_Click()
    arr = [a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For j = 2 To UBound(arr)
        If Not d.exists(arr(j, 2) & "") Then
            d(arr(j, 2) & "") = arr(j, 1) - arr(j, 4)
        Else
            d(arr(j, 2) & "") = d(arr(j, 2) & "") - arr(j, 4)
        End If
        arr(j, 6) = d(arr(j, 2) & "")
    Next j
    [a1].CurrentRegion = arr
End Sub

liulang0808

附件内容供参考

AVEL

用公式是否也可以？

1. =IFERROR(VLOOKUP(A2,$A$1:E1,5,),VLOOKUP(A2,$A$1:B2,2,))-D2

复制代码

张起灵1

liulang0808 发表于 2024-3-19 13:44
Sub 按钮1_Click()
    arr = [a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")

是我想要的，感谢！

张起灵1

AVEL 发表于 2024-3-19 13:45
用公式是否也可以？

函数我会的，正是想用VBA，实际数据有一万+行

清风竹-

请看附件。

笨鸟飞不高

子件需求.zip (48.45 KB, 下载次数: 3)

2024-3-19 14:01 上传

点击文件名下载附件

ykcbf1100

凑个热闹吧。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.3.19
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("Sheet1")
   
6.         r = .Cells(.Rows.Count, "b").End(xlUp).Row
   
7.         arr = .[a1].Resize(r, 5)
   
8.         For i = 2 To UBound(arr)
   
9.             s = arr(i, 2)
   
10.             d(s) = d(s) + arr(i, 4)
    
11.             arr(i, 5) = arr(i, 1) - d(s)
    
12.         Next
    
13.         .[a1].Resize(r, 5) = arr
    
14.     End With
    
15.     Set d = Nothing
    
16.     Application.ScreenUpdating = True
    
17.     MsgBox "OK！"
    
18. End Sub
    

复制代码