ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[已解决] 动态提取行列数据并统计满足条件(行列标题值)的个数

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-11-5 13:10 | 显示全部楼层 |阅读模式
本帖最后由 sunw1984 于 2019-11-6 15:50 编辑

各位老师:
       我初学VBA,目前遇到一个问题如下,还请不吝赐教
       sheet2为系统抽出的考试成绩,在sheet3想通过C2的部门(Dpt)来分别提出:
       ①sheet2数据库中的参加考试人员名单填入sheet3的C8往下的列,作为列标题
       ②抽出已参加的考试科目(Kemu)填入sheet3的D7以右的单元格,作为行标题
       ③在行列交叉区域统计满足行标题和列标题的个数,填入交叉单元格
       ④增加两列统计数目的列

      我试着用ADO已实现依据sheet3 C2的部门(Dpt)值动态引入新表的行(即上面的1)和列(即上面的2),但是第③个就不太会了,尝试用嵌套动态循环(行i,列j)来统计,发现结果能达到,但是EXCEL容易死掉(非常慢,元数据有四万多个行)

      因此恳请各位达人老师是否有别的办法帮我实现快速统计出结果,在此先说声谢谢了

附图:

截图示意

截图示意

部分数据.zip

88.75 KB, 下载次数: 8

TA的精华主题

TA的得分主题

发表于 2019-11-6 08:56 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-11-6 09:20 | 显示全部楼层
  1. Sub test()
  2.   Dim r%, i%
  3.   Dim arr, brr
  4.   Dim d As Object
  5.   Set d1 = CreateObject("scripting.dictionary")
  6.   Set d2 = CreateObject("scripting.dictionary")
  7.   With Worksheets("sheet3")
  8.     r = .Cells(.Rows.Count, 3).End(xlUp).Row
  9.     c = .Cells(7, .Columns.Count).End(xlToLeft).Column
  10.     .Range("d8").Resize(r - 7, c - 3).ClearContents
  11.     arr = .Range("c7").Resize(r - 6, c - 2)
  12.     tj1 = .Range("c2")
  13.   End With
  14.   For i = 2 To UBound(arr)
  15.     d1(arr(i, 1)) = i
  16.   Next
  17.   For j = 2 To UBound(arr, 2)
  18.     d2(arr(1, j)) = j
  19.   Next
  20.   With Worksheets("sheet2")
  21.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  22.     brr = .Range("a2:f" & r)
  23.   End With
  24.   For i = 1 To UBound(brr)
  25.     If brr(i, 3) = tj1 Then
  26.       If d1.exists(brr(i, 2)) Then
  27.         m = d1(brr(i, 2))
  28.         If d2.exists(brr(i, 4)) Then
  29.           n = d2(brr(i, 4))
  30.           arr(m, n) = arr(m, n) + 1
  31.         End If
  32.       End If
  33.     End If
  34.   Next
  35.   For i = 2 To UBound(arr)
  36.     s1 = 0
  37.     s2 = 0
  38.     For j = 2 To UBound(arr, 2) - 2
  39.       If Len(arr(i, j)) <> 0 Then
  40.         s1 = s1 + 1
  41.       End If
  42.       If arr(i, j) >= 2 Then
  43.         s2 = s2 + 1
  44.       End If
  45.     Next
  46.     If s1 <> 0 Then
  47.       arr(i, UBound(arr, 2) - 1) = Round(s1 / (UBound(arr, 2) - 3), 4)
  48.       arr(i, UBound(arr, 2)) = Round(s2 / s1, 4)
  49.     End If
  50.   Next
  51.   With Worksheets("sheet3")
  52.     .Columns("x:y").NumberFormatLocal = "0.00%"
  53.     .Range("c7").Resize(UBound(arr), UBound(arr, 2)) = arr
  54.   End With
  55. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2019-11-6 09:21 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-11-6 09:21 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
详见附件。

部分数据.rar

93.28 KB, 下载次数: 39

TA的精华主题

TA的得分主题

发表于 2019-11-6 10:56 | 显示全部楼层
本帖最后由 NaCl_cn 于 2019-11-6 10:57 编辑

用SQL聚合函数来做,不是很难,看附件
PS:哦 哦 忘记了说,我稍微改了一下你的业务逻辑,因为我觉得你之前的业务逻辑好像有点问题。你看一下,这样是不是符合你的要求。

部分数据.rar

92.33 KB, 下载次数: 19

TA的精华主题

TA的得分主题

发表于 2019-11-6 12:45 | 显示全部楼层

  1. Private Sub CommandButton1_Click()
  2.     Dim d As Object
  3.     Dim aArr, bArr, cArr(), tgStr, tArr(1 To 2), xArr
  4.     Set d = CreateObject("scripting.dictionary")
  5.     aArr = Sheet2.UsedRange
  6.     tgStr = Sheet3.[c2]
  7.     Intersect(Sheet3.Rows("8:" & Sheet3.UsedRange.Rows.Count), Sheet3.Columns("c:Y")).ClearContents
  8.     For i = 2 To UBound(aArr, 1)
  9.         If aArr(i, 3) = tgStr Then
  10.             d(aArr(i, 2) & "," & aArr(i, 4)) = d(aArr(i, 2) & "," & aArr(i, 4)) + 1
  11.         End If
  12.     Next
  13.     tArr(1) = d.keys
  14.     tArr(2) = d.items
  15.     bArr = WorksheetFunction.Transpose(tArr)
  16.     d.RemoveAll
  17.     For i = 1 To UBound(bArr, 1)
  18.         d(Split(bArr(i, 1), ",")(0)) = d(Split(bArr(i, 1), ",")(0))
  19.     Next
  20.     ReDim cArr(1 To UBound(bArr, 1), 1 To 3)
  21.     For i = 1 To UBound(cArr, 1)
  22.         cArr(i, 1) = Split(bArr(i, 1), ",")(0)
  23.         cArr(i, 2) = Split(bArr(i, 1), ",")(1)
  24.         cArr(i, 3) = bArr(i, 2)
  25.     Next
  26.     tArr(1) = d.keys
  27.     Erase aArr
  28.     aArr = WorksheetFunction.Transpose(Sheet3.[c7:y7])
  29.     ReDim Preserve aArr(1 To 23, 1 To d.Count + 1)
  30.     For i = 2 To UBound(aArr, 2)
  31.         aArr(1, i) = tArr(1)(i - 2)
  32.     Next
  33.     aArr = WorksheetFunction.Transpose(aArr)
  34.     For i = 2 To UBound(aArr, 1)
  35.         For j = 1 To UBound(cArr, 1)
  36.             If aArr(i, 1) = cArr(j, 1) Then
  37.                 For k = 2 To UBound(aArr, 2) - 2
  38.                     If aArr(1, k) = cArr(j, 2) Then
  39.                         aArr(i, k) = cArr(j, 3)
  40.                         n = n + 1
  41.                         If aArr(i, k) >= 2 Then m = m + 1
  42.                     End If
  43.                 Next k
  44.             End If
  45.         Next j
  46.         aArr(i, 22) = n / 20
  47.         aArr(i, 23) = m / n
  48.         n = 0
  49.         m = 0
  50.     Next i
  51.     Sheet3.[c7].Resize(UBound(aArr, 1), UBound(aArr, 2)) = aArr
  52.     Sheet3.[c7].CurrentRegion.Sort [c7], xlAscending, Header:=xlYes
  53. End Sub
复制代码

试一下还可以

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-11-6 15:43 | 显示全部楼层

非常感谢您的方法,这个方法确实很快,比嵌套循环速度快很多。

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-11-6 15:49 | 显示全部楼层
在此对各位@chxw68 @microyip @microyip @NaCl_cn @Jason_WangSS表示感谢,谢谢各位给予的指导,解决了我工作的实际问题,也学到了新的东西,谢谢

PS:EXCEL字典的方法我不太熟,还需继续学习,现在各位给的这个方法我修改应用到实际中,速度确实很快
@NaCl_cn 这个方法目的也达到了,谢谢。但相比字典来说,数据量大了跟我使用的嵌套循环差不多,速度会受到影响,数据是一行行/一列列的逐个填写进去,需要等待(有时EXCEL会假死)
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-19 18:58 , Processed in 0.051415 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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