[已解决]求跨表操作提取折旧的模块代替原函数公式

icenotcool · 发表于 2014-3-27 12:25

本帖最后由 icenotcool 于 2014-3-28 11:09 编辑

各位老师，想请老师帮我写跨表操作提取折旧的模块代替原函数公式作用，详情在附件内，谢谢老师了！附件

举例更新.rar (392.54 KB, 下载次数: 45)

grf1973 · 发表于 2014-3-27 16:36

Sub 更新报表1()
arr = Sheets("系统参数设置").[a1].CurrentRegion
Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr) '把"资产处理"工作表"所属部门" 和 "折旧表总账"工作表"科室" 用字典联系起来
d(arr(i, 3)) = arr(i, 4)
Next
arr = Sheets("系统参数设置").[K1:L25]
For i = 2 To UBound(arr) '把"资产处理"工作表"资产类别" 和 "资产分类" 用字典联系起来
d(arr(i, 2)) = arr(i, 1)
Next
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
arr = Sheets("资产处理").[a1].CurrentRegion
For i = 2 To UBound(arr)
bm = arr(i, 8): ks = d(bm) '部门-->总帐科室
lb = arr(i, 3): fl = d(lb) '资产类别-->总帐资产分类
xkey = ks & fl '字典的key
d1(xkey) = d1(xkey) + arr(i, 4) '资产原值
d2(xkey) = d2(xkey) + arr(i, 12) '计提折旧
Next
With Sheets("折旧表总账")
arr = .[A1:I41]
ReDim brr(4 To UBound(arr), 2 To 9)
For i = 4 To UBound(arr)
ks = arr(i, 1) '科室
For j = 2 To 8 Step 2
fl = arr(2, j) '资产分类
xkey = ks & fl
brr(i, j) = d1(xkey) '资产原值
brr(i, j + 1) = d2(xkey) '计提折旧
Next
Next
.[b4].Resize(UBound(brr) - 4, 8) = brr
.Cells(40, 2).Resize(1, 8).Formula = "=sum(r4c:r[-1]c)" '计算第40行“小计”
End With
End Sub

复制代码

grf1973 · 发表于 2014-3-27 16:39

和公式计算的比较了一下，大多数都是对的，就最后“行政后勤”几个数不对。我把不对的数值用红色标出来了。

grf1973 · 发表于 2014-3-27 16:40

另外一张表基本可以完全套用此代码，把表名改一下就行了。

icenotcool · 发表于 2014-3-27 17:07

本帖最后由 icenotcool 于 2014-3-27 21:12 编辑

谢谢老师了，老师，但是第41行“财政拨付”这个科室单列的数据没有统计出来，我改成42就可以了，还有老师第二个报表的绿色区域要特殊处理的数据该怎么写呢？还有第2个表有2个小计该怎么写呢？（备注：折旧要考虑上面红色区域分摊特别处理。），麻烦老师了，第2个表我改动如下：
Sub 更新报表2()
arr = Sheets("系统参数设置").[a1].CurrentRegion
Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr) '把"资产处理"工作表"所属部门" 和  "折旧表成本核算"工作表"科室" 用字典联系起来
      d(arr(i, 3)) = arr(i, 5)
Next
arr = Sheets("系统参数设置").[K1:L25]
For i = 2 To UBound(arr) '把"资产处理"工作表"资产类别" 和  "资产分类" 用字典联系起来
      d(arr(i, 2)) = arr(i, 1)
Next

Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
arr = Sheets("资产处理").[a1].CurrentRegion
For i = 2 To UBound(arr)
      bm = arr(i, 8): ks = d(bm) '部门-->成本核算科室
      lb = arr(i, 3): fl = d(lb) '资产类别-->总帐资产分类
      xkey = ks & fl '字典的key
      d1(xkey) = d1(xkey) + arr(i, 4) '资产原值
      d2(xkey) = d2(xkey) + arr(i, 12) '计提折旧
Next

With Sheets("折旧表成本核算")
      arr = .[A1:I52]
      ReDim brr(4 To UBound(arr), 2 To 9)
      For i = 4 To UBound(arr)
         ks = arr(i, 1)       '科室
         For j = 2 To 8 Step 2
            fl = arr(2, j)    '资产分类
            xkey = ks & fl
            brr(i, j) = d1(xkey) '资产原值
            brr(i, j + 1) = d2(xkey)  '计提折旧
         Next
      Next
      .[b4].Resize(UBound(brr) - 4, 8) = brr
      .Cells(45, 2).Resize(1, 8).Formula = "=sum(r4c:r[-1]c)" '计算第45行“小计”
   .[b46].Resize(UBound(brr) - 4, 8) = brr                                                          '这个我不会改
      .Cells(50, 2).Resize(1, 8).Formula = "=sum(r46c:r[-1]c)" '计算第50行“小计”  '这个我不会改
End With

End Sub
请老师纠正，麻烦老师了！

grf1973 · 发表于 2014-3-28 09:57

第1个问题：第41行“财政拨付”，代码最后第二句.[b4].Resize(UBound(brr) - 4, 8) = brr改成.[b4].Resize(UBound(brr) - 3, 8) = brr。因为数组brr下标是从4开始的，所以行数应该是Uboud(arr)-4+1。一开始调试的时候没有注意。

icenotcool · 发表于 2014-3-28 10:44

谢谢老师，可以了，老师，麻烦你再帮我看看第二张表，可以吗？第二张表，有2个科室数据需要分摊处理

grf1973 · 发表于 2014-3-28 10:59

arr = Sheets("系统参数设置").[a1].CurrentRegion
Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr) '把"资产处理"工作表"所属部门" 和 "折旧表成本核算"工作表"科室" 用字典联系起来
d(arr(i, 3)) = arr(i, 5)
Next
arr = Sheets("系统参数设置").[K1:L25]
For i = 2 To UBound(arr) '把"资产处理"工作表"资产类别" 和 "资产分类" 用字典联系起来
d(arr(i, 2)) = arr(i, 1)
Next
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
arr = Sheets("资产处理").[a1].CurrentRegion
For i = 2 To UBound(arr)
bm = arr(i, 8): ks = d(bm) '部门-->总帐科室
lb = arr(i, 3): fl = d(lb) '资产类别-->总帐资产分类
xkey = ks & fl '字典的key
d1(xkey) = d1(xkey) + arr(i, 4) '资产原值
d2(xkey) = d2(xkey) + arr(i, 12) '计提折旧
Next
With Sheets("折旧表成本核算")
arr = .[A1:I53]
ReDim brr(4 To UBound(arr), 2 To 9)
For i = 4 To UBound(arr)
ks = arr(i, 1) '科室
For j = 2 To 8 Step 2
fl = arr(2, j) '资产分类
xkey = ks & fl
brr(i, j) = d1(xkey) '资产原值
brr(i, j + 1) = d2(xkey) '计提折旧
Next
Next
.[b4].Resize(UBound(brr) - 3, 8) = brr
.[b45].Resize(1, 8).Formula = "=sum(r4c:r[-1]c)" '计算第45行“小计”
.[b50].Resize(1, 8).Formula = "=sum(r4c:r[-1]c)-r[-5]c" '计算第50行“小计”（全部小计-第45行小计）
End With
End Sub
Sub 分摊处理()
Set d = CreateObject("scripting.dictionary")
With Sheets("折旧表成本核算")
arr = .[A1:I53]
brr = .[m1].CurrentRegion
For j = 2 To 3
For i = 1 To UBound(brr) Step 2
ks = Replace(brr(i, j), "比例", "")
If j = 2 Then d(ks) = d(ks) + brr(i + 1, 1) * brr(i + 1, j) '行政后勤
If j = 3 Then d(ks) = d(ks) - brr(i + 1, 1) + brr(i + 1, 1) * brr(i + 1, j) '其他科室
Next
Next
For i = 4 To UBound(arr)
ks = arr(i, 1)
If d.exists(ks) Then .Cells(i, 5) = .Cells(i, 5) + d(ks)
Next
End With
End Sub

复制代码

grf1973 · 发表于 2014-3-28 11:00

这个最佳答案由 grf1973 给出，感谢 grf1973 的回答。

单击隐藏图章

分摊处理我单独弄了段代码。另外第一张表的小计也处理过了。

icenotcool · 发表于 2014-3-28 11:08

真是谢谢老师了，至于数据出现误差，应该是我设置的科室有遗漏，我核查一下就可以了，谢谢老师，辛苦了！

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