ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
高效办公必会的Office实战技巧 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel函数公式学习大典 高效办公之神操作 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 突破Excel限制,用活字格提高效率 13门Excel免费公开课任你学
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 188|回复: 9

[求助] VBA多条件求和汇总

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-5-15 22:45 | 显示全部楼层 |阅读模式

求助多条件求和汇总,盼老师们指点:
目的:1、清空黄色区域,2、多条件汇总填入对应单元格(详见附件)。
1、清空黄色区域的代码已完成。
2、多条件求和代码写不对,求助解决。
3、求和的三个条件:日期、产品名称、工序号。


样本.zip

34.17 KB, 下载次数: 15

TA的精华主题

TA的得分主题

发表于 2018-5-16 00:07 | 显示全部楼层
看看是不是这样?
  1. Sub qqq()                                  '多条件汇总
  2.    Dim d, ar, br, cr, dr
  3.     Set d = CreateObject("Scripting.Dictionary")
  4.     ar = Sheet1.Range("A1").CurrentRegion
  5.     br = Sheet2.[e2:ab63]: cr = Sheet2.[a2:a63]: dr = Sheet2.[b2:b63]
  6.     For i = 2 To UBound(ar)
  7.         s = ar(i, 1) & ar(i, 2) & ar(i, 3)
  8.         d(s) = d(s) + ar(i, 4)
  9.         If ar(i, 2) = "" Then
  10.             s = ar(i, 1) & ar(i, 2) & ar(i, 3)
  11.             d(s) = d(s) + ar(i, 4)
  12.         End If
  13.     Next
  14.     For i = 3 To UBound(br)
  15.         For j = 2 To UBound(br, 2) Step 2
  16.             br(i, j) = d(br(1, j - 1) & cr(i, 1) & dr(i, 1))
  17.         Next
  18.     Next
  19.     Sheet2.[e2:ab63] = br
  20. End Sub
复制代码

评分

参与人数 1鲜花 +2 收起 理由
alexagain + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-5-16 00:09 | 显示全部楼层
  1. Sub qiuhe()
  2.     Application.ScreenUpdating = False
  3.     Set dic = CreateObject("scripting.dictionary")
  4.     arr = [a2].CurrentRegion
  5.     brr = Sheets("日报表").[a1].CurrentRegion
  6.     For i = 4 To UBound(arr)
  7.         For j = 5 To UBound(arr, 2)
  8.             If Len(arr(2, j)) > 0 Then
  9.                 ms = DateValue(arr(2, j)) & arr(i, 1) & arr(i, 2)
  10.                 dic(ms) = i & "|" & j + 1
  11.             End If
  12.         Next j
  13.     Next i
  14.     For i = 2 To UBound(brr)
  15.         ms = DateValue(brr(i, 1)) & brr(i, 2) & brr(i, 3)
  16.         If dic.exists(ms) Then
  17.             x = Val(Split(dic(ms), "|")(0))
  18.             y = Val(Split(dic(ms), "|")(1))
  19.             Cells(x, y) = Cells(x, y) + brr(i, 4)
  20.         End If
  21.     Next i
  22.     Application.ScreenUpdating = True
  23. End Sub
复制代码


代码供参考

评分

参与人数 1鲜花 +2 收起 理由
alexagain + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-5-16 04:19 | 显示全部楼层


Sub step1()           'clear yellow area  
Application.ScreenUpdating = False
Dim rng As Range
For i = 1 To 150 Step 2
    If i = 1 Then
        Set rng = Range(Cells(4, i + 5), Cells(63, i + 5))
    Else
        Set rng = Application.Union(rng, Range(Cells(4, i + 5), Cells(63, i + 5)))
    End If
Next
rng.Select
Selection.ClearContents
Application.ScreenUpdating = True
End Sub

Sub step2()           'calculate yellow area sum  
ar = Sheet1.Range("A1").CurrentRegion
Set B = Sheet2.[e2:ab2]
R = Sheet2.[A65000].End(3).Row
'---------------------------------
For i = 1 To B.Cells.Count Step 2
    For j = 1 To R - 3
        C1 = B.Cells(i)
        C2 = Sheet2.Cells(j + 3, 1)
        C3 = Sheet2.Cells(j + 3, 2)
        B.Cells(i).Offset(j + 1).Offset(, 1).Value = CCheck(ar, C1, C2, C3, i, j)
    Next
Next
End Sub

Function CCheck(ar, C1, C2, C3, i, j)
    For k = 1 To UBound(ar)
        If ar(k, 1) = C1 And ar(k, 2) = C2 And ar(k, 3) = C3 Then
            S = S + ar(k, 4)
        End If
    Next
    CCheck = S
End Function


ttest1.zip

34.81 KB, 下载次数: 8

评分

参与人数 1鲜花 +2 收起 理由
alexagain + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-5-16 06:26 | 显示全部楼层
本帖最后由 lsc900707 于 2018-5-16 06:28 编辑

求和代码修改一下就好了:
  1. Sub qqq()                                  '多条件汇总
  2.     Set d = CreateObject("Scripting.Dictionary")
  3.     ar = Sheet1.Range("A1").CurrentRegion
  4.     br = [a1].CurrentRegion
  5.     For i = 2 To UBound(ar)
  6.         s = ar(i, 1) & ar(i, 2) & ar(i, 3)
  7.         d(s) = d(s) + ar(i, 4)
  8.     Next
  9.     For i = 4 To UBound(br)
  10.         For j = 5 To UBound(br, 2) - 1 Step 2
  11.             s = br(2, j) & br(i, 1) & br(i, 2)
  12.             If d.exists(s) Then br(i, j + 1) = d(s)
  13.         Next
  14.     Next
  15.    [a1].CurrentRegion = br
  16. End Sub
复制代码

评分

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

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-5-16 06:30 | 显示全部楼层
附件供参考:

样本.rar

25.61 KB, 下载次数: 23

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-5-16 12:40 | 显示全部楼层
非常感谢各位老师的帮助,所有代码都测试过,都正确。谢谢!
这方面,我还要更加努力学习。

TA的精华主题

TA的得分主题

发表于 2018-5-16 18:37 | 显示全部楼层
alexagain 发表于 2018-5-16 12:40
非常感谢各位老师的帮助,所有代码都测试过,都正确。谢谢!
这方面,我还要更加努力学习。

回帖要点对方的帖子下方的“回复”,这样就知道你有反馈。
可以尝试给帮助者“评分”来表示谢意!

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-5-17 18:38 | 显示全部楼层
lsc900707 发表于 2018-5-16 18:37
回帖要点对方的帖子下方的“回复”,这样就知道你有反馈。
可以尝试给帮助者“评分”来表示谢意!

知道了,谢谢指导!

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-5-17 18:43 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

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

关注官方微信,高效办公专列,每天发车

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

GMT+8, 2018-5-21 22:59 , Processed in 0.091899 second(s), 17 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

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

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

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