ExcelHome技术论坛

 找回密码
 免费注册
QQ登录 只需一步,快速开始
   
高效办公必会的Office99uu优优 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel函数公式学习大典 职场充电黑科技, Office微99uu优优 免费下载Excel行业应用视频
300集Office 2010微99uu优优 Tableau-数据可视化工具 突破Excel限制,用活字格提高效率 12门Excel免费公开课任你学
你的Excel 201099uu优优学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 263|回复: 13
打印 上一主题 下一主题

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

[复制链接]
TA的精华主题TA的得分主题
跳转到指定楼层
1
发表于 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的得分主题
2
发表于 2018-2-13 07:16 | 只看该作者
欢迎新朋友
楼主的需求没有看懂,如果要遍历多个文件,可以参考以下链接
http://club.excelhome.net/thread-1258425-1-1.html
TA的精华主题TA的得分主题
3
发表于 2018-2-13 07:47 | 只看该作者
测试…………留个印记
  • Sub dsmch()
  • Dim arr, brr, crr, d
  • Set d = CreateObject("scripting.dictionary")
  • arr = Sheet3.Range("a2").CurrentRegion
  • brr = Sheet6.Range("a1").CurrentRegion
  • ReDim crr(1 To UBound(brr) - 1, 1 To 2)
  • For i = 2 To UBound(arr)
  •     For j = 3 To 4
  •         zf = arr(i, 2) & "," & arr(1, j)
  •         d(zf) = arr(i, j)
  •     Next
  • Next
  • With CreateObject("vbscript.regexp")
  •     .Pattern = "\d+"
  •     .Global = True
  •     For i = 2 To UBound(brr)
  •         For j = 4 To 5
  •             brr(i, j) = brr(i, 3)
  •             For Each m In .Execute(brr(i, j))
  •                 brr(i, j) = Replace(brr(i, j), m, d(m & "," & brr(1, j)))
  •             Next
  •             crr(i - 1, j - 3) = Application.Evaluate(brr(i, j))
  •         Next
  •     Next
  • End With
  • Sheet6.Range("d2").Resize(UBound(crr), 2) = crr
  • End Sub
  • 复制代码

    评分

    参与人数 1鲜花 +2 收起 理由
    乐乐2006201505 + 2 优秀作品
    查看全部评分
    TA的精华主题TA的得分主题
    4
    发表于 2018-2-13 08:31 | 只看该作者
    TA的精华主题TA的得分主题
    5
    发表于 2018-2-13 08:34 | 只看该作者
    本帖最后由 jsgj2023 于 2018-2-13 08:36 编辑
    dsmch 发表于 2018-2-13 07:47
    测试…………留个印记

    加上机构切换功能就完美啦!每个机构的科目余额都是不一样的!
    TA的精华主题TA的得分主题
    6
    发表于 2018-2-13 10:17 | 只看该作者
    拆分运算符号有些费事,不知道是否有更简洁的方法

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

  •                 With Sheet6
  •                     Set Rng = .Range(.[c2], .Cells(.Rows.Count, 2).End(xlUp)).Resize(, 4)
  •                     aRes = Rng.Value
  •                     For i = 1 To UBound(aRes)
  •                         If Len(aRes(i, 2)) = 0 Then
  •                             aRes(i, 3) = "": aRes(i, 4) = ""
  •                         Else
  •                             s = CStr(aRes(i, 2))
  •                             aKemu = Split(VBA.Replace(s, "-", "+"), "+")
  •                             n = 0: m = UBound(aKemu): ReDim aSign(m)
  •                             aSign(0) = 1: n = Len(aKemu(0))
  •                             If m = 0 Then
  •                                 If Dic.exists(s) Then
  •                                     aRes(i, 3) = Dic(s)(0): aRes(i, 4) = Dic(s)(1)
  •                                 Else
  •                                     aRes(i, 3) = "Err": aRes(i, 4) = "Err"
  •                                 End If
  •                             Else
  •                                 For j = 1 To m
  •                                     aSign(j) = IIf(Mid(s, n + 1, 1) = "+", 1, -1)
  •                                     n = n + 1 + Len(aKemu(j))
  •                                 Next
  •                                 aRes(i, 3) = 0: aRes(i, 4) = 0
  •                                 For j = 0 To m
  •                                     If Dic.exists(CStr(aKemu(j))) Then
  •                                         aRes(i, 3) = aRes(i, 3) + Val(Dic(CStr(aKemu(j)))(0)) * aSign(j)
  •                                         aRes(i, 4) = aRes(i, 4) + Val(Dic(CStr(aKemu(j)))(1)) * aSign(j)
  •                                     Else
  •                                         aRes(i, 3) = "Err": aRes(i, 4) = "Err"
  •                                         Exit For
  •                                     End If
  •                                 Next
  •                             End If
  •                         End If
  •                     Next
  •                     Rng.Value = aRes
  •                 End With

  •             End If
  •         End If
  •     End With
  •     Set Dic = Nothing
  •     Application.EnableEvents = True
  • End Sub

  • 复制代码
    TA的精华主题TA的得分主题
    7
    发表于 2018-2-13 10:19 | 只看该作者
    示例文件

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



    TA的精华主题TA的得分主题
    8
    发表于 2018-2-13 10:48 | 只看该作者
    本帖最后由 jsgj2023 于 2018-2-13 10:52 编辑

  • Private Sub Worksheet_Change(ByVal Target As Range)
  • Application.EnableEvents = False
  •     Dim arr As Variant
  •     Dim O As Variant
  •     Set d = CreateObject("scripting.dictionary")
  •     With Sheets("基础数据")
  •         arr = .Range("a2").CurrentRegion
  •         For x = 2 To UBound(arr)
  •             For i = 3 To 4
  •                 d(arr(x, 1) & "," & arr(x, 2) & "," & arr(1, i)) = arr(x, i)
  •             Next
  •         Next
  •     End With
  •     With Sheets("口径")
  •         O = .Range("a2")
  •         brr = .Range("a1").CurrentRegion
  •         For y = 2 To UBound(brr)
  •          If Len(.Cells(y, 3)) Then
  •             For j = 4 To 5
  •                     .Cells(y, j) = Extract(.Cells(y, 3), O, .Cells(1, j))
  •             Next
  •         End If
  •         Next
  •     End With
  • Application.EnableEvents = True
  • End Sub

  • 复制代码
    TA的精华主题TA的得分主题
    9
    发表于 2018-2-13 10:49 | 只看该作者
  • Public d As Object
  • Function Extract(s As Variant, s1 As Variant, s3 As Variant)
  •     Dim Result As Variant
  •     Dim lSum As Variant
  •     With CreateObject("vbscript.regexp")
  •         .Pattern = "\d+"
  •         .Global = True
  •         Set mat = .Execute(s)
  •         For Each ma In mat
  •             temp1 = s1 & "," & ma & "," & s3
  •             If d.exists(temp1) Then lSum = d(temp1)
  •                Result = Replace(s, ma, lSum)
  •                s = Result
  •                lSum = 0
  •         Next
  •         Extract = Application.Evaluate(Result)
  •     End With
  • End Function

  • 复制代码
    TA的精华主题TA的得分主题
    10
    发表于 2018-2-13 10:49 | 只看该作者
    选择不同的机构,得出不同的余额!
    Adele-分析表.zip 255 KB, 下载次数: 17
    您需要登录后才可以回帖 登录 | 免费注册
    本版积分规则
    关闭

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

    关注官方微信,每天学会一个新技能
    手机版|关于我们|联系我们|ExcelHome GMT+8, 2018-2-26 09:11 , Processed in 0.089633 second(s), 19 queries , Gzip On, MemCache On.
    Powered by Discuz! X3.4 © 2001-2017 Wooffice Inc.
        沪公网安备 31011702000001号 沪ICP备11019229号 本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师
    快速回复 返回顶部 返回列表
    99uu优优