请教如何在现有逐级汇总的基础上加入C列的计算规则

kezhiye · 发表于 2019-2-21 23:43

本帖最后由 kezhiye 于 2019-2-22 08:51 编辑

A列代码长度是有规律的，分别为1、4、7、10、13位数，第1位相同的为一级，前4位相同的为二级，前7位相同的为三级，前1 0位相同的为四级，13位相同的为末级。

点击“生成汇总”按钮，得到现在的结果，其功能为逐级汇总。但是，目前的汇总结果没有考虑计算规则的加减，如年初金额李四的结果是50，而不是30-20=10，同理，其上级1221001、1221和第一行的1也都跟着多了40。

请教如何在现有逐级汇总的基础上加入C列的计算规则？不胜感激

逐级汇总如何加入计算规则.rar (194.58 KB, 下载次数: 11)

chxw68 · 发表于 2019-2-22 09:30

C列的计算规则只对E列有用，还是对所有需要计算的列都起作用？

kezhiye · 发表于 2019-2-22 09:44

本帖最后由 kezhiye 于 2019-2-22 09:46 编辑

chxw68 发表于 2019-2-22 09:30
C列的计算规则只对E列有用，还是对所有需要计算的列都起作用？

对DEFGHIKL八列起作用，也就是除期末金额和期末数量以外的起作用

chxw68 · 发表于 2019-2-22 10:04

kezhiye 发表于 2019-2-22 09:44
对DEFGHIKL八列起作用，也就是除期末金额和期末数量以外的起作用

你把原来的”本月“改成了”分1”，现在不知道哪个是累计的，哪个是本月的。

chxw68 · 发表于 2019-2-22 10:10

Sub 逐级汇总()
Dim r%, i%
Dim arr, brr
Dim d As Object
't = yfs
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With Worksheets("代码科目")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:g" & r)
End With
ReDim brr(1 To UBound(arr), 1 To 13)
For i = 1 To UBound(arr)
For j = 1 To 3
brr(i, j) = arr(i, j)
Next
brr(i, 4) = arr(i, 6)
brr(i, 5) = arr(i, 7)
d(brr(i, 1)) = i
Next
k = 6
For Each ws In Worksheets(Array("明细", "分1"))
With ws
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:l" & r)
For i = 1 To UBound(arr)
If d.Exists(arr(i, 2)) Then
m = d(arr(i, 2))
brr(m, k) = brr(m, k) + arr(i, 10)
brr(m, k + 1) = brr(m, k + 1) + arr(i, 12)
End If
Next
k = k + 2
End With
Next
fla = False
For i = UBound(brr) - 1 To 1 Step -1
bm = brr(i, 1)
ReDim crr(4 To 13)
j = i + 1
Do While brr(j, 1) Like bm & "*"
If brr(j, 1) Like bm & "###" Then
For k = LBound(crr) To UBound(crr)
If k = 10 Or k = 13 Then
crr(k) = crr(k) + brr(j, k)
Else
If brr(j, 3) = "加" Then
crr(k) = crr(k) + brr(j, k)
Else
crr(k) = crr(k) - brr(j, k)
End If
End If
Next
fla = True
End If
j = j + 1
If j > UBound(brr) Then
Exit Do
End If
Loop
If fla Then
For k = LBound(crr) To UBound(crr)
brr(i, k) = crr(k)
Next
fla = False
d1(i) = Len(brr(i, 1))
End If
Next
With Worksheets("汇总")
.UsedRange.Offset(1, 0).Clear
.Columns(1).NumberFormatLocal = "@"
.Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
r = 1 + UBound(brr)
With .Range("a1:m1")
.HorizontalAlignment = xlCenter
End With
With .UsedRange
.VerticalAlignment = xlCenter
With .Font
.Size = 10
End With
End With
With .Range("a2:a" & r)
.HorizontalAlignment = xlLeft
End With
.Range("a1:m" & r).Borders.LineStyle = xlContinuous
For Each aa In d1.keys
Select Case d1(aa)
Case 1
ys = 22
Case 4
ys = 40
Case 7
ys = 37
Case Else
ys = 15
End Select
.Cells(aa + 1, 1).Resize(1, 13).Interior.ColorIndex = ys
Next
End With
End Sub

复制代码

chxw68 · 发表于 2019-2-22 10:12

修改好了。

kezhiye · 发表于 2019-2-22 11:02

汇总结果与之前的结果有点差异，现在本楼重新上传附件，看是否说清楚了问题。

假如B工地的计算规则为减，其三个下级也都为减，那么B工地的合计结果要为3，不能为-3。

只有象李四那样，其下级合计为20-30=-10才显示负10

逐级汇总如何加入计算规则B.rar (199.27 KB, 下载次数: 2)

chxw68 · 发表于 2019-2-22 11:27

修改好了。

kezhiye · 发表于 2019-2-22 12:29

chxw68 发表于 2019-2-22 11:27
修改好了。

非常感谢chxw68老师多次热情耐心的帮助！上述汇总结果达到了我想要的效果，在此表示衷心的感谢。
如果汇总结果就放在“代码科目”工作表相应的单元格，VBA代码要怎么修改呢？

逐级汇总如何加入计算规则C.rar (201 KB, 下载次数: 1)

chxw68 · 发表于 2019-2-22 12:39

修改好了。

		自动登录	找回密码
密码			免费注册

[求助] 请教如何在现有逐级汇总的基础上加入C列的计算规则

评分

最新热点 /1