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

ynzsvt

1. Sub LHTEEE合计()
   
2. Dim Arr, i, j, Dic As Object, Brr
   
3. Set Dic = CreateObject("Scripting.Dictionary")
   
4. Arr = Range(Cells(2, "C"), Cells(Rows.Count, "B").End(xlUp))
   
5. ReDim Brr(1 To UBound(Arr), 0)
   
6. For i = UBound(Arr) To 1 Step -1
   
7.   If Not Dic.Exists(Arr(i, 1)) Then Dic(Arr(i, 1)) = i
   
8.   j = Dic(Arr(i, 1))
   
9.   Brr(j, 0) = Brr(j, 0) + Arr(i, 2)
   
10. Next
    
11. 
    
12. [D2].Resize(UBound(Brr)) = Brr
    
13. Set Dic = Nothing
    
14. End Sub

复制代码

kyxfyzg

Sub tese()
Set d = CreateObject("scripting.dictionary")
arr = Range("b1").CurrentRegion
For i = 2 To UBound(arr)
    If d.Exists(arr(i, 1)) Then
        d(arr(i, 1)) = Array(d(arr(i, 1))(0) + arr(i, 2), i)
    Else
        d(arr(i, 1)) = Array(arr(i, 2), i)
    End If
Next i
brr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(d.Items))
For i = 1 To UBound(brr)
    Cells(brr(i, 2), 4) = brr(i, 1)
Next i
End Sub

gwjkkkkk

Option Explicit
Sub test1()
    Dim ar, i&, p&, n&, vTemp
   
    With [B1].CurrentRegion
        p = 2
        ar = .Resize(.Rows.Count + 1)
        For i = 2 To UBound(ar) - 1
            ar(i, 3) = Empty: vTemp = vTemp + ar(i, 2)
            If ar(i + 1, 1) <> ar(p, 1) Then
                ar(i, 3) = vTemp
                vTemp = Empty
                p = i + 1
            End If
        Next i
        .Value = ar
    End With
   
    Beep
End Sub

gwjkkkkk

。。。。。。。。

lhteee

没顾上看，我研究一下。谢谢各位大神&#128591;&#128591;&#128591;

dixuan0329

无关岁月 发表于 2024-8-7 10:37

逻辑清晰，代码易懂

petergaod

已经好久没看到这么简单的求助了

lhteee

petergaod 发表于 2024-8-8 11:11
已经好久没看到这么简单的求助了

菜鸟一只，谢谢大家！

lhteee

都很好用，谢谢各位大神！！！