Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2221|回复: 7

[已解决]vba遇到难题求教 一对多查询 还要连接起来

[复制链接]
发表于 2015-11-18 23:51 | 显示全部楼层 |阅读模式
成绩分析.rar (45 KB, 下载次数: 11)
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2015-11-19 00:56 | 显示全部楼层
老师,您不上附件,别人怎么帮您呢
回复

使用道具 举报

 楼主| 发表于 2015-11-19 06:32 | 显示全部楼层
回复

使用道具 举报

发表于 2015-11-19 10:24 | 显示全部楼层    本楼为最佳答案   
  1. Sub grf()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     Set d1 = CreateObject("scripting.dictionary")
  4.    
  5.     km = "语文"     '科目
  6.     arr = Sheets("成绩").[a1].CurrentRegion
  7.     For i = 2 To UBound(arr)     '各班级的实考人数和总成绩
  8.         x = arr(i, 1) & arr(i, 4)   '学校+班级为key
  9.         If arr(i, 5) > 0 Then '成绩大于0为实考
  10.             d(x) = d(x) + 1
  11.             d1(x) = d1(x) + arr(i, 5)
  12.         End If
  13.     Next
  14.    
  15.     arr = Sheets("教师").[a1].CurrentRegion
  16.     ReDim brr(1 To UBound(arr), 1 To 6)
  17.     For i = 2 To UBound(arr)
  18.         xm = arr(i, 4)    '姓名
  19.         x = arr(i, 1) & arr(i, 2)      '学校+班级
  20.         If Not d.exists(xm) Then
  21.             n = n + 1
  22.             d(xm) = n
  23.             brr(n, 1) = arr(i, 1)
  24.             brr(n, 2) = xm
  25.             brr(n, 4) = km
  26.         End If
  27.         p = d(xm)
  28.         brr(p, 3) = IIf(Len(brr(p, 3)) = 0, arr(i, 2), brr(p, 3) & "," & arr(i, 2))
  29.         brr(p, 5) = brr(p, 5) + d(x)
  30.         brr(p, 6) = brr(p, 6) + d1(x)
  31.     Next
  32.     For p = 1 To n
  33.         rs = rs + brr(p, 5) '人数
  34.         zf = zf + brr(p, 6) '总分
  35.         brr(p, 6) = brr(p, 6) / brr(p, 5)     '平均分
  36.     Next
  37.    
  38.     With Sheets("结果")
  39.         .[a5].Resize(n, 6) = brr
  40.         .[a4] = "合    计"
  41.         .[d4] = km
  42.         .[e4] = rs
  43.         .[f4] = zf / rs
  44.         .[g5].Resize(n).Formula = "=rank(rc[-1],r5c[-1]:r" & 4 + n & "c[-1])"   '名次
  45.     End With
  46. End Sub
复制代码
回复

使用道具 举报

发表于 2015-11-19 10:25 | 显示全部楼层
请看附件。

成绩分析基础 - 副本.rar

48.19 KB, 下载次数: 18

回复

使用道具 举报

发表于 2015-11-19 13:10 | 显示全部楼层
换个使用工作表函数的思路,供参考。
  1. Sub grf1()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     Set d1 = CreateObject("scripting.dictionary")
  4.     Set sh = Worksheets("成绩")
  5.     km = "语文"     '科目
  6.     arr = Sheets("教师").[a1].CurrentRegion
  7.     ReDim brr(1 To UBound(arr), 1 To 6)
  8.     For i = 2 To UBound(arr)
  9.         xm = arr(i, 4)    '姓名
  10.         x = arr(i, 1) & arr(i, 2)      '学校+班级
  11.         If Not d.exists(xm) Then
  12.             n = n + 1
  13.             d(xm) = n
  14.             brr(n, 1) = arr(i, 1)
  15.             brr(n, 2) = xm
  16.             brr(n, 4) = km
  17.         End If
  18.         p = d(xm)
  19.         brr(p, 3) = brr(p, 3) & "," & arr(i, 2)
  20.         brr(p, 5) = brr(p, 5) + Application.WorksheetFunction.CountIfs(sh.[a:a], arr(i, 1), sh.[d:d], arr(i, 2), sh.[e:e], ">0")
  21.         brr(p, 6) = brr(p, 6) + Application.WorksheetFunction.SumIfs(sh.[e:e], sh.[a:a], arr(i, 1), sh.[d:d], arr(i, 2))
  22.     Next
  23.     For p = 1 To n
  24.         brr(p, 3) = Mid(brr(p, 3), 2)
  25.         rs = rs + brr(p, 5) '人数
  26.         zf = zf + brr(p, 6) '总分
  27.         brr(p, 6) = brr(p, 6) / brr(p, 5)     '平均分
  28.     Next
  29.    
  30.     With Sheets("结果")
  31.         .[a5].Resize(n, 6) = brr
  32.         .[a4] = "合    计"
  33.         .[d4] = km
  34.         .[e4] = rs
  35.         .[f4] = zf / rs
  36.         .[g5].Resize(n).Formula = "=rank(rc[-1],r5c[-1]:r" & 4 + n & "c[-1])"   '名次
  37.     End With
  38. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2015-11-21 12:08 | 显示全部楼层
本帖最后由 yh6201 于 2015-11-21 15:53 编辑

经过测试  实在是太高效了

谢谢
回复

使用道具 举报

发表于 2015-11-22 11:02 | 显示全部楼层
太厉害了 没附件都可以  求助过几次  都是楼上答复的  厉害{:361:}
回复

使用道具 举报

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

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 19:15 , Processed in 0.694427 second(s), 13 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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