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

lhteee

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



演示.rar (9.39 KB, 下载次数: 23)

2024-8-8 20:31 上传

点击文件名下载附件

shiruiqiang

字典(项目)=array(借方,贷方)

无关岁月

1. Sub 按钮1_Click()
   
2. Dim arr, i, sum1, sum2, m
   
3. arr = [a1].CurrentRegion.Offset(2)
   
4. For i = 1 To UBound(arr) - 1
   
5.     sum1 = sum1 + arr(i, 2): sum2 = sum2 + arr(i, 3)
   
6.     If arr(i, 1) <> arr(i + 1, 1) Then
   
7.         m = m + 1
   
8.         arr(m, 1) = arr(i, 1)
   
9.         arr(m, 2) = sum1
   
10.         arr(m, 3) = sum2
    
11.         sum1 = 0: sum2 = 0
    
12.     End If
    
13. Next
    
14. [e3].Resize(m, 3) = arr
    
15. End Sub

复制代码

lhteee

shiruiqiang 发表于 2024-8-8 20:55
字典(项目)=array(借方,贷方)

对代码一窍不通，只会比葫芦画瓢，还望大神赐予代码！

shiruiqiang

Sub test()
Dim arr, brr
Dim dic
Set dic = CreateObject("scripting.dictionary")
arr = Sheets(1).[a1].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 3)
For x = 3 To UBound(arr)
If Not dic.exists(arr(x, 1)) Then
dic(arr(x, 1)) = Array(arr(x, 2), arr(x, 3))
Else
dic(arr(x, 1)) = Array(dic(arr(x, 1))(0) + arr(x, 2), dic(arr(x, 1))(1) + arr(x, 3))
End If
Next

For Each d In dic.keys
k = k + 1
brr(k, 1) = d
brr(k, 2) = dic(d)(0)
brr(k, 3) = dic(d)(1)
Next

Sheets(1).[e10].Resize(k, 3) = brr

End Sub

quqiyuan

参与一下。。。

lhteee

quqiyuan 发表于 2024-8-8 21:45
参与一下。。。

谢谢！如果在原表位置生成，将其他数据删除，可不可以改进代码？

hongshan2019

lhteee 发表于 2024-8-9 08:42
谢谢！如果在原表位置生成，将其他数据删除，可不可以改进代码？

原标位置删除，把arr放下就成了

morpheus126

数据透视表了解一下。。。

lhteee

本意是想在原表格位置上生成新表格，并且将其他多余的数据删除。
可能是我没有表达清楚，还望各位大神赐教！
&#128591;&#128591;&#128591;