ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
高效办公必会的Office实战技巧 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel函数公式学习大典 Office 365免费试用,报名现在开始! 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 打造核心竞争力的职场宝典 13门Excel免费公开课任你学
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 462|回复: 16

[求助] 如何用VBA实现指定条件数据求和

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-2-12 21:26 | 显示全部楼层 |阅读模式
求助各位大神!
M公司有很多不同的分公司,每个公司有各自的会计科目表,如何按照指定公式求和某一家分公司的部分会计科目之和。
例如A 1001科目100
          102001科目 100
          103001科目 5
          2105科目   3
          ......
      B  1001科目1000
          102001科目 1000
          103001科目 5
          2105科目   30
          ......
想实现的功能是按照指定公式求和不同分公司的会计科目余额之和
      机构     公式                                        结果
        A      1001+102001+103001-2105       202
        B      1001-102001+2105-103001        25

分析表.xls.zip

186.36 KB, 下载次数: 20

计算要求

TA的精华主题

TA的得分主题

发表于 2018-2-13 07:16 | 显示全部楼层
欢迎新朋友
楼主的需求没有看懂,如果要遍历多个文件,可以参考以下链接
http://club.excelhome.net/thread-1258425-1-1.html

TA的精华主题

TA的得分主题

发表于 2018-2-13 07:47 | 显示全部楼层
测试…………留个印记
  1. Sub dsmch()
  2. Dim arr, brr, crr, d
  3. Set d = CreateObject("scripting.dictionary")
  4. arr = Sheet3.Range("a2").CurrentRegion
  5. brr = Sheet6.Range("a1").CurrentRegion
  6. ReDim crr(1 To UBound(brr) - 1, 1 To 2)
  7. For i = 2 To UBound(arr)
  8.     For j = 3 To 4
  9.         zf = arr(i, 2) & "," & arr(1, j)
  10.         d(zf) = arr(i, j)
  11.     Next
  12. Next
  13. With CreateObject("vbscript.regexp")
  14.     .Pattern = "\d+"
  15.     .Global = True
  16.     For i = 2 To UBound(brr)
  17.         For j = 4 To 5
  18.             brr(i, j) = brr(i, 3)
  19.             For Each m In .Execute(brr(i, j))
  20.                 brr(i, j) = Replace(brr(i, j), m, d(m & "," & brr(1, j)))
  21.             Next
  22.             crr(i - 1, j - 3) = Application.Evaluate(brr(i, j))
  23.         Next
  24.     Next
  25. End With
  26. Sheet6.Range("d2").Resize(UBound(crr), 2) = crr
  27. End Sub
复制代码

评分

参与人数 1鲜花 +2 收起 理由
乐乐2006201505 + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-2-13 08:31 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2018-2-13 08:34 | 显示全部楼层
本帖最后由 jsgj2023 于 2018-2-13 08:36 编辑
dsmch 发表于 2018-2-13 07:47
测试…………留个印记

加上机构切换功能就完美啦!每个机构的科目余额都是不一样的!

TA的精华主题

TA的得分主题

发表于 2018-2-13 10:17 | 显示全部楼层
拆分运算符号有些费事,不知道是否有更简洁的方法

  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim Dic, aData, aRes, sKey, aKemu
  3.     Application.EnableEvents = False
  4.     With Target
  5.         If .Count = 1 Then
  6.             If .Address = "$A$2" And Len(.Value) > 0 Then
  7.                 sKey = .Value
  8.                 With Sheet3
  9.                     aData = .Range(.[a3], .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 4).Value
  10.                     Set Dic = CreateObject("scripting.dictionary")
  11.                     For i = 1 To UBound(aData)
  12.                         If aData(i, 1) = sKey Then Dic(CStr(aData(i, 2))) = Array(aData(i, 3), aData(i, 4))
  13.                     Next
  14.                 End With

  15.                 With Sheet6
  16.                     Set Rng = .Range(.[c2], .Cells(.Rows.Count, 2).End(xlUp)).Resize(, 4)
  17.                     aRes = Rng.Value
  18.                     For i = 1 To UBound(aRes)
  19.                         If Len(aRes(i, 2)) = 0 Then
  20.                             aRes(i, 3) = "": aRes(i, 4) = ""
  21.                         Else
  22.                             s = CStr(aRes(i, 2))
  23.                             aKemu = Split(VBA.Replace(s, "-", "+"), "+")
  24.                             n = 0: m = UBound(aKemu): ReDim aSign(m)
  25.                             aSign(0) = 1: n = Len(aKemu(0))
  26.                             If m = 0 Then
  27.                                 If Dic.exists(s) Then
  28.                                     aRes(i, 3) = Dic(s)(0): aRes(i, 4) = Dic(s)(1)
  29.                                 Else
  30.                                     aRes(i, 3) = "Err": aRes(i, 4) = "Err"
  31.                                 End If
  32.                             Else
  33.                                 For j = 1 To m
  34.                                     aSign(j) = IIf(Mid(s, n + 1, 1) = "+", 1, -1)
  35.                                     n = n + 1 + Len(aKemu(j))
  36.                                 Next
  37.                                 aRes(i, 3) = 0: aRes(i, 4) = 0
  38.                                 For j = 0 To m
  39.                                     If Dic.exists(CStr(aKemu(j))) Then
  40.                                         aRes(i, 3) = aRes(i, 3) + Val(Dic(CStr(aKemu(j)))(0)) * aSign(j)
  41.                                         aRes(i, 4) = aRes(i, 4) + Val(Dic(CStr(aKemu(j)))(1)) * aSign(j)
  42.                                     Else
  43.                                         aRes(i, 3) = "Err": aRes(i, 4) = "Err"
  44.                                         Exit For
  45.                                     End If
  46.                                 Next
  47.                             End If
  48.                         End If
  49.                     Next
  50.                     Rng.Value = aRes
  51.                 End With

  52.             End If
  53.         End If
  54.     End With
  55.     Set Dic = Nothing
  56.     Application.EnableEvents = True
  57. End Sub

复制代码

TA的精华主题

TA的得分主题

发表于 2018-2-13 10:19 | 显示全部楼层
示例文件

分析表.zip (255.35 KB, 下载次数: 10)

TA的精华主题

TA的得分主题

发表于 2018-2-13 10:48 | 显示全部楼层
本帖最后由 jsgj2023 于 2018-2-13 10:52 编辑

  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. Application.EnableEvents = False
  3.     Dim arr As Variant
  4.     Dim O As Variant
  5.     Set d = CreateObject("scripting.dictionary")
  6.     With Sheets("基础数据")
  7.         arr = .Range("a2").CurrentRegion
  8.         For x = 2 To UBound(arr)
  9.             For i = 3 To 4
  10.                 d(arr(x, 1) & "," & arr(x, 2) & "," & arr(1, i)) = arr(x, i)
  11.             Next
  12.         Next
  13.     End With
  14.     With Sheets("口径")
  15.         O = .Range("a2")
  16.         brr = .Range("a1").CurrentRegion
  17.         For y = 2 To UBound(brr)
  18.          If Len(.Cells(y, 3)) Then
  19.             For j = 4 To 5
  20.                     .Cells(y, j) = Extract(.Cells(y, 3), O, .Cells(1, j))
  21.             Next
  22.         End If
  23.         Next
  24.     End With
  25. Application.EnableEvents = True
  26. End Sub

复制代码

TA的精华主题

TA的得分主题

发表于 2018-2-13 10:49 | 显示全部楼层
  1. Public d As Object
  2. Function Extract(s As Variant, s1 As Variant, s3 As Variant)
  3.     Dim Result As Variant
  4.     Dim lSum As Variant
  5.     With CreateObject("vbscript.regexp")
  6.         .Pattern = "\d+"
  7.         .Global = True
  8.         Set mat = .Execute(s)
  9.         For Each ma In mat
  10.             temp1 = s1 & "," & ma & "," & s3
  11.             If d.exists(temp1) Then lSum = d(temp1)
  12.                Result = Replace(s, ma, lSum)
  13.                s = Result
  14.                lSum = 0
  15.         Next
  16.         Extract = Application.Evaluate(Result)
  17.     End With
  18. End Function

复制代码

TA的精华主题

TA的得分主题

发表于 2018-2-13 10:49 | 显示全部楼层
选择不同的机构,得出不同的余额!

Adele-分析表.zip

255 KB, 下载次数: 21

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2018-8-20 09:44 , Processed in 0.086000 second(s), 17 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表