vba提取不重复值

jyzx · 发表于 2015-7-20 00:10

本帖最后由 jyzx 于 2015-7-20 16:12 编辑

从一年级工作表的B列里提取不重复的年班到一年级汇总的A3以下单元格里。从B列开始用函数公式进行计算该学校该年级每一科的成绩。其它年级的一样。点击提取年班按钮同时完成1-6年级的提取。

jyzx · 发表于 2015-7-20 00:21

本帖最后由 jyzx 于 2015-7-20 16:10 编辑

一年级汇总里的提取：

huang1314wei · 发表于 2015-7-20 06:56

成绩汇总怎么汇总也不说一下？计算该学校该年级单科成绩总分还是什么呀，这么关键的东西都不说清楚？

jyzx · 发表于 2015-7-20 07:15

huang1314wei 发表于 2015-7-20 06:56
成绩汇总怎么汇总也不说一下？计算该学校该年级单科成绩总分还是什么呀，这么关键的东西都不说清楚？

对不起，是计算该学校该年级每一科的成绩。

huang1314wei · 发表于 2015-7-20 07:32

jyzx 发表于 2015-7-20 07:15
对不起，是计算该学校该年级每一科的成绩。

是该学校该年级班的每一科的成绩之和是吧

huang1314wei · 发表于 2015-7-20 08:16

Sub text()
Dim ws As Worksheet, arr, brr, i%, j%, m%, d, k
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
For Each ws In Worksheets
If ws.Name <> "目录" And InStr(ws.Name, "汇总") = 0 Then
arr = ws.Range("A1").CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 2)) = ""
Next
d.Remove "学校"
k = d.keys
ReDim brr(1 To d.Count, 1 To UBound(arr, 2) - 3)
ws.Range(ws.Cells(1, 5), ws.Cells(1, UBound(arr, 2))).Copy Worksheets(ws.Name & "汇总").Range("B2")
For i = 0 To d.Count - 1
brr(i + 1, 1) = k(i)
For j = 2 To UBound(arr)
If k(i) = arr(j, 2) Then
For m = 5 To UBound(arr, 2)
brr(i + 1, m - 3) = brr(i + 1, m - 3) + arr(j, m)
Next
End If
Next
Next
Worksheets(ws.Name & "汇总").Range("A3").Resize(d.Count, UBound(arr, 2) - 3) = brr
Worksheets(ws.Name & "汇总").UsedRange.Borders.LineStyle = xlContinuous
Worksheets(ws.Name & "汇总").Columns("A:I").AutoFit
End If
d.RemoveAll
Next
Application.ScreenUpdating = True
End Sub

复制代码

huang1314wei · 发表于 2015-7-20 08:17

附件供参考

新建文件夹.rar (283.15 KB, 下载次数: 88)

jyzx · 发表于 2015-7-20 13:19

huang1314wei 发表于 2015-7-20 08:17
附件供参考

只提取学校年班，不计算成绩。见二楼。

hlly888 · 发表于 2015-7-20 16:42

jyzx 发表于 2015-7-20 13:19
只提取学校年班，不计算成绩。见二楼。

提取年班.zip (392.15 KB, 下载次数: 83)

LMY123 · 发表于 2019-1-4 22:33

提取同薄多表B列不重复值-字典法，已入VBA代码宝库。

		自动登录	找回密码
密码			免费注册

[求助] vba提取不重复值