写一段VBA代码，将同一项目的借方、贷方都累计到同项目第一行，删除其他行。

lhteee

于箱长 发表于 2024-8-10 07:50
行 自己喜欢就好

解决了排序问题！

1. Sub 汇总()
   
2. Set 字典 = CreateObject("scripting.dictionary")
   
3. arr = Range([A2], Cells(Cells(Rows.Count, 1).End(xlUp).Row, 7))
   
4. For i = 1 To UBound(arr)
   
5. If 字典.exists(arr(i, 5)) Then
   
6. 字典(arr(i, 5)) = Array(字典(arr(i, 5))(0), 字典(arr(i, 5))(1) + arr(i, 6), 字典(arr(i, 5))(2) + arr(i, 7))
   
7. Else
   
8. 字典(arr(i, 5)) = Array(arr(i, 5), arr(i, 6), arr(i, 7))
   
9. End If
   
10. Next i
    
11. brr = Application.Transpose(Application.Transpose(字典.items))
    
12. [A2].Resize([a1].CurrentRegion.Rows.Count - 0, [a1].CurrentRegion.Columns.Count - 0).ClearContents
    
13. '[A2:G50000].Clear
    
14. [E2].Resize(UBound(brr), UBound(brr, 2)) = brr
    
15. End Sub
    

复制代码

Qs18

Sub qs()
Dim arr, i, dic
Set dic = CreateObject("scripting.dictionary")
With Sheet1
    arr = .Range("a1").CurrentRegion.Value
    ReDim brr(1 To UBound(arr), 1 To 3)
    For i = 2 To UBound(arr)
        s = arr(i, 1)
        If Not dic.exists(s) Then
            m = m + 1
            dic(s) = m
            brr(m, 1) = s: brr(m, 2) = arr(i, 2): brr(m, 3) = arr(i, 3)
        Else
            rw = dic(s)
            brr(rw, 2) = brr(rw, 2) + arr(i, 2)
            brr(rw, 3) = brr(rw, 3) + arr(i, 3)
        End If
    Next
.Range("e2").Resize(m, 3) = brr
End With
End Sub

Qs18

试试...........

Qs18

试试.........

lhteee

Qs18 发表于 2024-8-11 15:24
试试.........

谢谢，我研究一下！