用VBA代码实现自动判断相同项目，并将合计数填列到项目的最后一行右侧

lhteee

演示.rar (8.2 KB, 下载次数: 18)

2024-8-7 08:59 上传

点击文件名下载附件

GDVBXX

参与一下...！

longwin

Sub test()
    arr = [b1].CurrentRegion
    xm = arr(2, 1): je = 0
    For i = 2 To UBound(arr)
        If arr(i, 1) = xm Then
            je = je + arr(i, 2)
        Else
            arr(i - 1, 3) = je
            je = arr(i, 2)
            xm = arr(i, 1)
        End If
    Next
   arr(i - 1, 3) = je
[b1].CurrentRegion = arr
End Sub

limonet

两个公式。

sdytsxd991122

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.8.7
   
2.     r = Cells(Rows.Count, 2).End(3).Row
   
3.     arr = [b1].Resize(r, 3)
   
4.     On Error Resume Next
   
5.     For i = 2 To UBound(arr)
   
6.         If arr(i, 1) <> arr(i - 1, 1) Then Sum = arr(i, 2): arr(i, 3) = 0
   
7.         If arr(i, 1) = arr(i - 1, 1) Then Sum = Sum + arr(i, 2): arr(i, 3) = 0
   
8.         If i < r And arr(i, 1) <> arr(i + 1, 1) Then arr(i, 3) = Sum
   
9.     Next
   
10.     [d1].Resize(r, 1) = Application.Index(arr, 0, 3)
    
11.     ActiveWindow.DisplayZeros = False
    
12.     MsgBox "OK！"
    
13. End Sub
    
14. 
    

复制代码

无关岁月

1. Sub test()
   
2. Dim arr, i, sum
   
3. arr = [b1].CurrentRegion.Offset(1)
   
4. For i = 1 To UBound(arr) - 1
   
5.     sum = sum + arr(i, 2)
   
6.     If arr(i, 1) <> arr(i + 1, 1) Then
   
7.             arr(i, 3) = sum
   
8.         sum = 0
   
9.     End If
   
10. Next
    
11. [b2].Resize(UBound(arr), UBound(arr, 2)) = arr
    
12. End Sub
    

复制代码

zhangcheng6688

学习一下字典，打扰了
Sub test()
arr = [b1].CurrentRegion
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
   d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
   d1(arr(i, 1)) = i
Next
For i = 2 To UBound(arr)
   If i = d1(arr(i, 1)) Then
      arr(i, 3) = d(arr(i, 1))
   End If
Next
Columns(4).NumberFormat = "0.00"
[b1].CurrentRegion = arr
End Sub

songshihai

数据少用单元格循环,如果数据多自己改成数组