ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

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

[求助] 如何根据原始表135列和班主任生成统计表和3个名单表20170618

[复制链接]

TA的精华主题

TA的得分主题

发表于 2017-6-18 09:57 | 显示全部楼层 |阅读模式
原始表:第1列为填报状态(已填报,未填报),第3列为班级,第5列为姓名
统计表:已填报,未填报各班人数;
全部名单:已填报姓名后无标记,未填报后打×,第4行为全部人数=已填报人数+未填报人数,如299=229+70
已填报名单、未填报名单
班主任:为各班级的班主任名单
目标:直接根据原始表生成名单及统计表 如何根据原始表135列和班主任生成统计表和3个名单表20170618.rar (26.81 KB, 下载次数: 22)

TA的精华主题

TA的得分主题

发表于 2017-6-18 10:58 | 显示全部楼层
可以用字典套字典实现,建议搜索类似帖子。

TA的精华主题

TA的得分主题

发表于 2017-6-18 11:12 来自手机 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2017-6-18 11:34 | 显示全部楼层
  1. Sub test()
  2.   Dim r%, i%
  3.   Dim arr, brr
  4.   Dim d As Object
  5.   Set d = CreateObject("scripting.dictionary")
  6.   Set dcs = CreateObject("scripting.dictionary")
  7.   With Worksheets("班主任")
  8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  9.     arr = .Range("a1:b" & r)
  10.     For i = 1 To UBound(arr)
  11.       xm = Format(arr(i, 1), "00")
  12.       dcs(xm) = arr(i, 2)
  13.     Next
  14.   End With
  15.   With Worksheets("原始表")
  16.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  17.     arr = .Range("a3:e" & r)
  18.     For i = 1 To UBound(arr)
  19.       bj = Mid(arr(i, 3), 4, 2)
  20.       If Not d.exists(bj) Then
  21.         m = 4
  22.         ReDim brr(1 To m)
  23.         brr(1) = bj
  24.         If dcs.exists(bj) Then
  25.           brr(2) = dcs(bj)
  26.         End If
  27.         brr(3) = Array(0, 0)
  28.       Else
  29.         brr = d(bj)
  30.         m = UBound(brr) + 1
  31.         ReDim Preserve brr(1 To m)
  32.       End If
  33.       If arr(i, 1) = "已填报" Then
  34.         brr(3)(0) = brr(3)(0) + 1
  35.         brr(m) = arr(i, 5)
  36.       Else
  37.         brr(3)(1) = brr(3)(1) + 1
  38.         brr(m) = arr(i, 5) & "×"
  39.       End If
  40.       d(bj) = brr
  41.     Next
  42.   End With
  43.   With Worksheets("全部名单")
  44.     .UsedRange.Offset(1, 0).Clear
  45.     .Range("a2") = "班级"
  46.     .Range("a3") = "班主任"
  47.     n = 2
  48.     For k = 1 To 15
  49.       xm = Format(k, "00")
  50.       If d.exists(xm) Then
  51.         brr = d(xm)
  52.         brr(3) = brr(3)(0) + brr(3)(1) & "=" & brr(3)(0) & "+" & brr(3)(1)
  53.         crr = Application.Transpose(brr)
  54.         .Cells(2, n).Resize(UBound(crr), 1) = crr
  55.         n = n + 1
  56.       End If
  57.     Next
  58.     r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
  59.     For i = 4 To r
  60.       .Cells(i, 1) = i - 3
  61.     Next
  62.   End With
  63. End Sub
复制代码

评分

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

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-6-18 11:35 | 显示全部楼层
只写了生成“全部名单”的代码。

如何根据原始表135列和班主任生成统计表和3个名单表20170618.rar

35.74 KB, 下载次数: 14

评分

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

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-6-18 11:47 | 显示全部楼层
  1. Sub 统计()
  2. Dim d As Object
  3. Dim arr, brr, crr As Variant
  4. Dim i, s, r As Integer
  5. Set d = CreateObject("scripting.dictionary")
  6. arr = Sheets("原始表").[a1].CurrentRegion
  7. brr = Sheets("统计表").[a1].CurrentRegion
  8. For i = 3 To UBound(arr)
  9. For r = 3 To UBound(brr)
  10. If arr(i, 3) = brr(r, 1) And arr(i, 1) = "已填报" Then
  11. brr(r, 2) = brr(r, 2) + 1
  12. End If
  13. If arr(i, 3) = brr(r, 1) And arr(i, 1) = "未填报" Then
  14. brr(r, 3) = brr(r, 3) + 1
  15. End If
  16. If arr(i, 3) = brr(r, 1) Then
  17. brr(r, 4) = brr(r, 4) + 1
  18. End If
  19. Next r
  20. If arr(i, 1) = "未填报" Then
  21. brr(2, 3) = brr(2, 3) + 1
  22. End If
  23. If arr(i, 1) = "已填报" Then
  24. brr(2, 2) = brr(2, 2) + 1
  25. End If
  26. brr(2, 4) = UBound(arr) - 2
  27. Next i
  28. For r = 3 To UBound(brr)
  29. brr(r, 5) = brr(r, 1) & "" & brr(r, 2) & "" & brr(r, 3) & "" & brr(r, 4)
  30. Next r
  31. brr(2, 5) = 0 & "" & brr(2, 2) & "" & brr(2, 3) & "" & brr(2, 4)
  32. Sheets("统计表").[a1].Resize(UBound(brr), UBound(brr, 2)) = brr
  33. End Sub
复制代码

评分

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

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-6-18 11:47 | 显示全部楼层
  1. Sub 名单()
  2. Dim d As Object
  3. Dim arr, brr, crr As Variant
  4. Dim i, s, r As Integer
  5. Set d = CreateObject("scripting.dictionary")
  6. brr = Sheets("原始表").[a1].CurrentRegion
  7. For i = 3 To UBound(brr)
  8. If brr(i, 1) = "未填报" Then
  9. brr(i, 5) = brr(i, 5) & "×"
  10. End If
  11. Next i
  12. For i = 3 To UBound(brr)
  13. If Not d.Exists(brr(i, 3)) Then
  14. d(brr(i, 3)) = brr(i, 5)
  15. Else
  16. d(brr(i, 3)) = d(brr(i, 3)) & "," & brr(i, 5)
  17. End If
  18. Next i
  19. x = d.Keys
  20. Sheets("全部名单").[b4:p500] = ""
  21. For i = 0 To UBound(x)
  22. crr = Split(d.Items()(i), ",")
  23. Sheets("全部名单").Cells(5, i + 2).Resize(UBound(crr) + 1, 1) = Application.Transpose(crr)
  24. Next i
  25. Sheets("全部名单").[b2].Resize(1, d.Count) = d.Keys
  26. For s = 2 To Sheets("全部名单").Cells(2, Columns.Count).End(xlToLeft).Column
  27. m = 0
  28. For k = 5 To Sheets("全部名单").Cells(Rows.Count, s).End(xlUp).Row
  29. If InStr(Sheets("全部名单").Cells(k, s), "×") > 0 Then
  30. m = m + 1
  31. End If
  32. Next k
  33. Sheets("全部名单").Cells(4, s) = Sheets("全部名单").Cells(Rows.Count, s).End(xlUp).Row - 4 & "=" & m & "+" & Sheets("全部名单").Cells(Rows.Count, s).End(xlUp).Row - 4 - m
  34. Next s
  35. End Sub
复制代码

评分

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

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-6-18 11:48 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2017-6-18 15:46 | 显示全部楼层
  1. Sub test()
  2.   Dim r%, i%
  3.   Dim arr, brr
  4.   Dim d(1 To 3) As Object
  5.   Dim shnam
  6.   shnam = [{"全部名单","已填报","未填报"}]
  7.   For i = 1 To 3
  8.     Set d(i) = CreateObject("scripting.dictionary")
  9.   Next
  10.   Set dcs = CreateObject("scripting.dictionary")
  11.   With Worksheets("班主任")
  12.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  13.     arr = .Range("a1:b" & r)
  14.     For i = 1 To UBound(arr)
  15.       xm = Format(arr(i, 1), "00")
  16.       dcs(xm) = arr(i, 2)
  17.     Next
  18.   End With
  19.   With Worksheets("原始表")
  20.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  21.     arr = .Range("a3:e" & r)
  22.     For i = 1 To UBound(arr)
  23.       bj = Mid(arr(i, 3), 4, 2)
  24.       If dcs.exists(bj) Then
  25.         bzr = dcs(bj)
  26.       Else
  27.         bzr = ""
  28.       End If
  29.       If Not d(1).exists(bj) Then
  30.         m = 4
  31.         ReDim brr(1 To m)
  32.         brr(1) = bj
  33.         brr(2) = bzr
  34.         brr(3) = Array(0, 0)
  35.       Else
  36.         brr = d(1)(bj)
  37.         m = UBound(brr) + 1
  38.         ReDim Preserve brr(1 To m)
  39.       End If
  40.       If arr(i, 1) = "已填报" Then
  41.         brr(3)(0) = brr(3)(0) + 1
  42.         brr(m) = arr(i, 5)
  43.       Else
  44.         brr(3)(1) = brr(3)(1) + 1
  45.         brr(m) = arr(i, 5) & "×"
  46.       End If
  47.       d(1)(bj) = brr
  48.     Next
  49.   End With
  50.   For Each aa In d(1).keys
  51.     brr = d(1)(aa)
  52.     ReDim crr(1 To UBound(brr))
  53.     ReDim drr(1 To UBound(brr))
  54.     For i = 1 To 2
  55.       crr(i) = brr(i)
  56.       drr(i) = brr(i)
  57.     Next
  58.     m = 3
  59.     n = 3
  60.     For i = 4 To UBound(brr)
  61.       If Right(brr(i), 1) <> "×" Then
  62.         m = m + 1
  63.         crr(m) = brr(i)
  64.         crr(3) = crr(3) + 1
  65.       Else
  66.         n = n + 1
  67.         drr(n) = Left(brr(i), Len(brr(i)) - 1)
  68.         drr(3) = drr(3) + 1
  69.       End If
  70.     Next
  71.     d(2)(aa) = crr
  72.     d(3)(aa) = drr
  73.   Next
  74.   For q = 1 To 3
  75.     With Worksheets(shnam(q))
  76.       .UsedRange.Offset(1, 0).Clear
  77.       .Range("a2") = "班级"
  78.       .Range("a3") = "班主任"
  79.       n = 2
  80.       For k = 1 To 15
  81.         xm = Format(k, "00")
  82.         If d(q).exists(xm) Then
  83.           brr = d(q)(xm)
  84.           If q = 1 Then
  85.             brr(3) = brr(3)(0) + brr(3)(1) & "=" & brr(3)(0) & "+" & brr(3)(1)
  86.           End If
  87.           crr = Application.Transpose(brr)
  88.           .Cells(2, n).Resize(UBound(crr), 1) = crr
  89.           n = n + 1
  90.         End If
  91.       Next
  92.       r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
  93.       c = .Cells(2, .Columns.Count).End(xlToLeft).Column
  94.       For i = 4 To r
  95.         .Cells(i, 1) = i - 3
  96.       Next
  97.       .Range("a2").Resize(r - 1, c).Borders.LineStyle = xlContinuous
  98.       With .UsedRange
  99.         With .Font
  100.           .Size = 10
  101.         End With
  102.         .HorizontalAlignment = xlCenter
  103.         .VerticalAlignment = xlCenter
  104.       End With
  105.     End With
  106.   Next
  107. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2017-6-18 15:47 | 显示全部楼层
生成全部名单、已填报、未填报三个表的代码。

如何根据原始表135列和班主任生成统计表和3个名单表20170618.rar

34.53 KB, 下载次数: 19

评分

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

查看全部评分

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

本版积分规则

关闭

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

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

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

GMT+8, 2019-10-17 13:38 , Processed in 0.076108 second(s), 15 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

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

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

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