ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 365|回复: 2

求助各位老师:如何修改现代码,即能实现求和,同时能减去对应列的数值

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-1-11 23:43 | 显示全部楼层 |阅读模式
目前的K-N列的值只实现条件求和,怎么样修改现代码才能在现基础上,还会去减O-R中的值?
附件中有代码说明,也有最终的的效果表。
还请各位老师,帮解答

条件求和后再去减同列值.zip

766.81 KB, 下载次数: 5

附件

TA的精华主题

TA的得分主题

发表于 2020-1-12 01:56 | 显示全部楼层
你写得太复杂,一个字典应该能搞定

TA的精华主题

TA的得分主题

发表于 2020-1-12 08:41 | 显示全部楼层
  1. Sub 条件求和()
  2.   Dim r%, i%
  3.   Dim arr, brr
  4.   Dim d As Object
  5.   Application.ScreenUpdating = False '工作表里面数据发生变化后False禁止实时刷新,True为默认值表示实时更新数据。
  6.   Application.DisplayAlerts = False '屏蔽程序执行过程中出现的一些弹出框警告,设置为true就会显示弹出警告。
  7.   Set d = CreateObject("scripting.dictionary")
  8.   Set d1 = CreateObject("scripting.dictionary")
  9.   Set d2 = CreateObject("scripting.dictionary")
  10.   Set d3 = CreateObject("scripting.dictionary")
  11.   
  12.   With Worksheets("sheet1")
  13.     rq1 = .Range("d2")
  14.     rq2 = .Range("d3")
  15.   End With
  16.   
  17.   With Worksheets("sheet4")
  18.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  19.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
  20.     arr = .Range("a2").Resize(r - 1, c)
  21.     For i = 1 To UBound(arr)
  22.       If arr(i, 3) = "A001" Then
  23.         ReDim brr(1 To 17)
  24.         brr(1) = arr(i, 7)
  25.         xm = CStr(arr(i, 7)) '将括号内的数据转换为文本型,也就是string类型
  26.         d(xm) = brr
  27.       End If
  28.     Next
  29.   End With
  30.   
  31.   With Worksheets("sheet2")
  32.     r = .Cells(.Rows.Count, 3).End(xlUp).Row
  33.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
  34.     arr = .Range("a2").Resize(r - 1, c)
  35.     For i = 1 To UBound(arr)
  36.       xm = CStr(arr(i, 3))
  37.       If d.exists(xm) Then
  38.         brr = d(xm)
  39.         n = 0
  40.         Select Case Mid(arr(i, 10), 2, 2) '取第10列第2个字符开始,取2个字符
  41.           Case "QQ"
  42.             n = 1
  43.           Case "JJ"
  44.             n = 2
  45.           Case "XX"
  46.             n = 3
  47.           Case "TT"
  48.             n = 4
  49.         End Select
  50.         If n <> 0 Then
  51.           If Len(arr(i, 17)) < 5 Then '???Len():得到字符串的长度???
  52.             brr(n + 1) = brr(n + 1) + 1
  53.             If arr(i, 16) >= rq1 And arr(i, 16) <= rq2 Then
  54.               brr(n + 9) = (brr(n + 9) + 1) - .Cells(i, 15)
  55.             End If
  56.           Else
  57.             brr(n + 5) = brr(n + 5) + 1
  58.           End If
  59.         End If
  60.         d(xm) = brr
  61.       End If
  62.     Next
  63.   End With
  64.   
  65.   With Worksheets("sheet3")
  66.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  67.     c = .Cells(2, .Columns.Count).End(xlToLeft).Column
  68.     arr = .Range("a3").Resize(r - 2, c)
  69.     For i = 1 To UBound(arr)
  70.       xm = CStr(arr(i, 7))
  71.       If d.exists(xm) Then
  72.         brr = d(xm)
  73.         n = 0
  74.         Select Case Mid(arr(i, 6), 2, 2)
  75.           Case "QQ"
  76.             n = 1
  77.           Case "JJ"
  78.             n = 2
  79.           Case "XX"
  80.             n = 3
  81.           Case "TT"
  82.             n = 4
  83.         End Select
  84.         If n <> 0 Then
  85.           If Len(arr(i, 8)) < 5 Then
  86.             If arr(i, 5) >= rq1 And arr(i, 5) <= rq2 Then
  87.               brr(n + 13) = brr(n + 13) + 1
  88.             End If
  89.           End If
  90.         End If
  91.         d(xm) = brr
  92.       End If
  93.     Next
  94.   End With
  95.   
  96. t = d.items
  97. For x = 0 To d.Count - 1
  98.     For i = 0 To 3
  99.         t(x)(i + 10) = t(x)(i + 10) - t(x)(i + 14)
  100.     Next
  101. Next
  102.   
  103.   With Worksheets("sheet1")
  104.     .Range("a7:r" & .Rows.Count).Clear
  105.     If d.Count > 0 Then
  106.       With .Range("b7").Resize(d.Count, UBound(brr))
  107. '        .Value = Application.Transpose(Application.Transpose(d.items))
  108.         .Value = Application.Transpose(Application.Transpose(t))
  109.         .Borders.LineStyle = xlContinuous '区域单元格设置线
  110.       End With
  111.     End If
  112.     .Select
  113.   End With
  114.   
  115. End Sub
复制代码

评分

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

查看全部评分

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

本版积分规则

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

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

GMT+8, 2020-9-30 04:07 , Processed in 0.083233 second(s), 18 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2021 Wooffice Inc.

   

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

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

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