ExcelHome技术论坛

 找回密码
 免费注册
QQ登录 只需一步,快速开始
   
高效办公必会的Office99uu优优 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel函数公式学习大典 资深财务总监教您玩转Excel 免费下载Excel行业应用视频
300集Office 2010微99uu优优 Tableau-数据可视化工具 突破Excel限制,用活字格提高效率 13门Excel免费公开课任你学
你的Excel 201099uu优优学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 289|回复: 11
打印 上一主题 下一主题

[求助] 用Excel VBA字典功能完成

[复制链接]
TA的精华主题TA的得分主题
跳转到指定楼层
1
发表于 2018-4-16 19:28 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
本人用字典+数组完成了姓名和任课班级数两列,现在想实现如下要求:在任教学科列对应学科,班主任列如果是显示“是”,不是不显示。请高手赐教,不胜感激!也可用公式完成!
数组 字典练习.zip 24.4 KB, 下载次数: 22
TA的精华主题TA的得分主题
2
发表于 2018-4-16 20:24 | 只看该作者
高中老师吧  你的任教学科列中没有“是”字啊  所以无法判断
TA的精华主题TA的得分主题
3
发表于 2018-4-16 20:38 | 只看该作者
  • Sub Dodict()
  •     Dim d As Object, arr, brr, i&, j&, k&, s$
  •     Dim sht As Worksheet
  •     Set d = CreateObject("scripting.dictionary")
  •     For Each sht In Worksheets
  •         If sht.Name <> ActiveSheet.Name Then
  •             arr = sht.[a1].CurrentRegion
  •             For i = 2 To UBound(arr)
  •                 For j = 3 To UBound(arr, 2)
  •                     If Not d.exists(arr(i, j) & "," & j) Then
  •                         d(arr(i, j) & "," & j) = ""
  •                         d(arr(i, j)) = d(arr(i, j)) + 1
  •                     End If
  •                     If Not d.exists(arr(i, j) & "xk") Then
  •                         d(arr(i, j) & "xk") = "," & arr(1, j)
  •                     Else
  •                         s = d(arr(i, j) & "xk")
  •                         If InStr(s, arr(1, j)) = 0 Then
  •                             d(arr(i, j) & "xk") = s & "," & arr(1, j)
  •                         End If
  •                     End If
  •                 Next
  •                 d(arr(i, 2) & "bzr") = ""
  •             Next
  •         End If
  •     Next
  •     arr = [a1].CurrentRegion
  •     For i = 2 To UBound(arr)
  •         For j = 1 To UBound(arr, 2) - 4 Step 4
  •             For y = j + 1 To j + 3
  •                 arr(i, y) = ""
  •             Next
  •             If d.exists(arr(i, j)) Then
  •                 arr(i, j + 1) = d(arr(i, j))
  •                 arr(i, j + 2) = Mid(d(arr(i, j) & "xk"), 2)
  •             End If
  •             If d.exists(arr(i, j) & "bzr") Then arr(i, j + 3) = "是"
  •         Next
  •     Next
  •     [a1].CurrentRegion = arr
  •     MsgBox "ok"
  •     Set d = Nothing
  • End Sub
  • 复制代码

    评分

    参与人数 1财富 +20 收起 理由
    lsc900707 + 20 行云流水,一气呵成!
    查看全部评分
    TA的精华主题TA的得分主题
    4
    发表于 2018-4-16 20:39 | 只看该作者
    参考 数组 字典练习.rar (39.77 KB, 下载次数: 29)
    TA的精华主题TA的得分主题
    5
    发表于 2018-4-16 21:34 | 只看该作者
    TA的精华主题TA的得分主题
    6
     楼主| 发表于 2018-4-16 22:09 | 只看该作者
    TA的精华主题TA的得分主题
    7
     楼主| 发表于 2018-4-16 22:10 | 只看该作者
    TA的精华主题TA的得分主题
    8
     楼主| 发表于 2018-4-16 22:11 | 只看该作者
    谢谢各位高手的解答,特别是看见星光的解答,向您学习!
    TA的精华主题TA的得分主题
    9
     楼主| 发表于 2018-4-17 20:40 | 只看该作者
    再次请教请教高手,如果我想加一列,统计处每个教师任教的年级怎么实现(比如:在高一里代课则显示1,高二则2,高三则3,跨头的话则1,2;1,3;2,3;1,2,3等。谢谢!
    TA的精华主题TA的得分主题
    10
    发表于 2018-4-18 14:14 | 只看该作者
  • Sub 统计()
  •     Set d = CreateObject("scripting.dictionary")
  •     Set d1 = CreateObject("scripting.dictionary")
  •     Set d2 = CreateObject("scripting.dictionary")
  •     Set d3 = CreateObject("scripting.dictionary")
  •     For k = 1 To 3
  •         arr = Sheets(k).[a1].CurrentRegion
  •         For i = 2 To UBound(arr)
  •             d(arr(i, 2)) = "是" '班主任
  •             For j = 3 To UBound(arr, 2) - 1
  •                 xm = arr(i, j)
  •                 If xm <> "——" Then
  •                     If InStr(d1(xm), arr(i, 1)) = 0 Then d1(xm) = d1(xm) & "," & arr(i, 1) '班级
  •                     If InStr(d2(xm), k) = 0 Then d2(xm) = d2(xm) & "," & k   '年级
  •                     If InStr(d3(xm), arr(1, j)) = 0 Then d3(xm) = d3(xm) & "," & arr(1, j) '任教学科
  •                 End If
  •             Next
  •         Next
  •     Next
  •     With Sheets("统计")
  •         .Cells.ClearContents
  •         .[a1].Resize(1, 5) = Array("姓名", "任课班级数", "任教年级", "任教学科", "班主任")
  •         ReDim brr(1 To d1.Count, 1 To 5)
  •         For Each xm In d1.keys
  •             n = n + 1
  •             brr(n, 1) = xm
  •             brr(n, 2) = UBound(Split(d1(xm), ","))   '班级数
  •             brr(n, 3) = Mid(d2(xm), 2)
  •             brr(n, 4) = Mid(d3(xm), 2)
  •             brr(n, 5) = d(xm)
  •         Next
  •         .[a2].Resize(n, 5) = brr
  •     End With
  • End Sub
  • 复制代码
    数组 字典练习.rar 23.82 KB, 下载次数: 8
    您需要登录后才可以回帖 登录 | 免费注册
    本版积分规则
    关闭

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

    关注官方微信,每天学会一个新技能
    手机版|关于我们|联系我们|ExcelHome GMT+8, 2018-4-25 00:16 , Processed in 0.085385 second(s), 13 queries , Gzip On, MemCache On.
    Powered by Discuz! X3.4 © 2001-2017 Wooffice Inc.
        沪公网安备 31011702000001号 沪ICP备11019229号 本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师
    快速回复 返回顶部 返回列表
    99uu优优