ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 1745|回复: 11

[求助] VBA多工作表统计求和与排序

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-9-28 18:13 | 显示全部楼层 |阅读模式
本人VBA新手,最近工作遇到个问题。如图
1.png

源数据1

源数据1

源数据2

源数据2


需求:
填入起始和结束日期,点击统计按钮后
1、从sheet2,sheet3表中获取A列对应的投入数、良品数并求合,结果填入AA对应的投入数和良品数
2、从sheet2,sheet3中获取A列对应的各项不良总数并把最大的三项名称和名称对应的总数填入D:I相应的位置
如:1 在SHEET2,SHEET3中获取AA项目在9月11日至9月15日投入数的总和填入B2,良品数的总和填入C2,
       2 AA在SHEET2和SHEET3中不良数量最高的不良A填入到不良1对应位置,不良E填入到不良2对应位置
       3  求出不良A和不良E的总数占投入数的百分比,填入到不良1、和不良2的占比对应的单元格

TA的精华主题

TA的得分主题

发表于 2020-9-28 18:17 | 显示全部楼层
没有附件,啥也干不了!

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-9-28 18:19 | 显示全部楼层
多工作表分类统计.rar (14.73 KB, 下载次数: 3)
各位大老小弟已经想了两三天,本想在试试,但是时间太紧张了。。希望老大们帮帮忙

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-9-28 18:20 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
kuangben8 发表于 2020-9-28 18:17
没有附件,啥也干不了!

刚发的急没上传上来。我把附件上传了大佬 帮帮忙

TA的精华主题

TA的得分主题

发表于 2020-9-28 18:24 | 显示全部楼层
flyzz1209 发表于 2020-9-28 18:20
刚发的急没上传上来。我把附件上传了大佬 帮帮忙

把结果模拟一下,方便理解。。

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-9-28 18:28 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
kuangben8 发表于 2020-9-28 18:24
把结果模拟一下,方便理解。。

那个。。谅解怎么模拟呢。。是直接把我要的结果填一下吗。。

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-9-28 18:36 | 显示全部楼层
多工作表分类统计.rar (15.14 KB, 下载次数: 4)
您好。我模拟了项目AA的结果。。麻烦您帮忙 看一下。。因为没系统的学过VBA。没有比较清晰的思路和知识支撑。。麻烦您了

TA的精华主题

TA的得分主题

发表于 2020-9-28 18:59 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
  1. Sub test()
  2.   Dim r%, i%
  3.   Dim arr, brr
  4.   Dim ws As Worksheet
  5.   Dim d As Object
  6.   Set d = CreateObject("scripting.dictionary")
  7.   For Each ws In Worksheets
  8.     If ws.Name <> "Sheet1" Then
  9.       With ws
  10.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
  11.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
  12.         arr = .Range("a1").Resize(r, c)
  13.         For i = 2 To UBound(arr)
  14.           If Not d.exists(arr(i, 2)) Then
  15.             ReDim brr(1 To 4)
  16.             brr(1) = arr(i, 2)
  17.             Set brr(4) = CreateObject("scripting.dictionary")
  18.           Else
  19.             brr = d(arr(i, 2))
  20.           End If
  21.           brr(2) = brr(2) + arr(i, 3)
  22.           brr(3) = brr(3) + arr(i, 4)
  23.           For j = 6 To UBound(arr, 2)
  24.             brr(4)(arr(1, j)) = brr(4)(arr(1, j)) + arr(i, j)
  25.           Next
  26.           d(arr(i, 2)) = brr
  27.         Next
  28.       End With
  29.     End If
  30.   Next
  31.   ReDim crr(1 To d.Count, 1 To 9)
  32.   m = 0
  33.   For Each aa In d.keys
  34.     brr = d(aa)
  35.     m = m + 1
  36.     crr(m, 1) = brr(1)
  37.     crr(m, 2) = brr(2)
  38.     crr(m, 3) = brr(3)
  39.     ReDim drr(1 To brr(4).Count, 1 To 2)
  40.     n = 0
  41.     For Each bb In brr(4).keys
  42.       n = n + 1
  43.       drr(n, 1) = bb
  44.       drr(n, 2) = brr(4)(bb)
  45.     Next
  46.     For x = 1 To UBound(drr) - 1
  47.       p = x
  48.       For y = x + 1 To UBound(drr)
  49.         If drr(p, 2) < drr(y, 2) Then
  50.           p = y
  51.         End If
  52.       Next
  53.       If p <> x Then
  54.         For Z = 1 To UBound(drr, 2)
  55.           temp = drr(x, Z)
  56.           drr(x, Z) = drr(p, Z)
  57.           drr(p, Z) = temp
  58.         Next
  59.       End If
  60.     Next
  61.     n = 4
  62.     For i = 1 To Application.Min(3, UBound(drr))
  63.       crr(m, n) = drr(i, 1)
  64.       If Len(crr(m, 2)) <> 0 And crr(m, 2) <> 0 Then
  65.         crr(m, n + 1) = Round(drr(i, 2) / crr(m, 2), 4)
  66.       End If
  67.       n = n + 2
  68.     Next
  69.   Next
  70.   With Worksheets("sheet1")
  71.     .UsedRange.Offset(1, 0).Clear
  72.     .Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
  73.   End With
  74.   
  75. End Sub
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-9-28 18:59 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-9-28 19:19 | 显示全部楼层

非常感谢!大佬 。我想了三天的问题。。您这一会儿就给解决了。。太感谢了
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-28 23:08 , Processed in 0.052960 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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