向一张表中各行填加与另一张表对应的行号

zhaogang1960 · 发表于 2013-12-28 23:07

ahyyf 发表于 2013-12-28 22:50

Sub Macro1()
Dim arr, brr, crr(), d As Object, i&, r
Set d = CreateObject("scripting.dictionary")
arr = Sheets("地生考试成绩").Range("A1").CurrentRegion
For i = 2 To UBound(arr)
d(Mid(arr(i, 1), 5)) = i
Next
With Sheets("中考成绩")
brr = .Range("A1").CurrentRegion
ReDim crr(2 To UBound(brr), 1 To 3)
For i = 2 To UBound(brr)
r = d(Mid(brr(i, 1), 5, 2) & Right(brr(i, 1), 3))
If r <> "" Then
crr(i, 1) = arr(r, 5)
crr(i, 2) = arr(r, 6)
If brr(i, 2) <> arr(r, 2) Then crr(i, 3) = arr(r, 2)
End If
Next
.[k2].Resize(i - 2, 3) = crr
End With
End Sub

复制代码

zhaogang1960 · 发表于 2013-12-28 23:09

请测试附件

求助：成绩合并aa.rar (14.15 KB, 下载次数: 32)

ahyyf · 发表于 2013-12-29 14:09

zhaogang1960 发表于 2013-12-28 23:09
请测试附件

赵老师：我是想在初升高考试时，将上年度的地理、生物两科成绩提取到今年的表中，在总成绩中加入进来（有的学生2012年参加了地生考试，但2013年没有参加初升高考试，只提取参加初升高考试人员的地生考试成绩）。前后两表对应的是“地理生物考号”（中考成绩的第10列，地生考试成绩的第1列，都是2012列头的，要求以此号相对应，相同的才提取成绩，再核实一下名字，是否查同，有不同的也提取出来，防止在学校录入“地理生物考号”时录错，用了别人的成绩。谢谢！

zhaogang1960 · 发表于 2013-12-29 14:11

ahyyf 发表于 2013-12-29 14:09
赵老师：我是想在初升高考试时，将上年度的地理、生物两科成绩提取到今年的表中，在总成绩中加入进来（有 ...

我阅读困难，请上传附件，模拟效果说明要求

ahyyf · 发表于 2013-12-29 21:24

zhaogang1960 发表于 2013-12-29 14:11
我阅读困难，请上传附件，模拟效果说明要求

谢谢您！

求助：成绩提取.rar (10.48 KB, 下载次数: 2)

zhaogang1960 · 发表于 2013-12-29 21:32

ahyyf 发表于 2013-12-29 21:24
谢谢您！

2013010001 201201001
2013010002 201201002
2013010003 201201003
2013010004 201201004
2013010005 201201005
2013010006 201201006
先请解释这两列代码对应关系再说吧，我上面写的对应关系可能你不满意

ahyyf · 发表于 2013-12-29 21:57

zhaogang1960 发表于 2013-12-29 21:32
2013010001 201201001
2013010002 201201002
2013010003 201201003

2013010001
2013010002
2013010003
这列号没有用，两张表上的“地理生物考号”201201002等号相同是1个人，提取成绩。

ahyyf · 发表于 2013-12-29 22:02

ahyyf 发表于 2013-12-29 21:57
2013010001
2013010002
2013010003

张三丰等人今年参加初升高考试，考完试后，要把本次考试的五科成绩同上年度考试的两科（地理、生物）成绩加在初升高考试总分中，所以要提取地理、生物两科的成绩。

zhaogang1960 · 发表于 2013-12-29 22:06

ahyyf 发表于 2013-12-29 22:02
张三丰等人今年参加初升高考试，考完试后，要把本次考试的五科成绩同上年度考试的两科（地理、生物）成绩 ...

Sub Macro1()
Dim arr, brr, crr(), d As Object, i&, r
Set d = CreateObject("scripting.dictionary")
arr = Sheets("2012年地生考试成绩").Range("A1").CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 1)) = i
Next
With Sheets("中考成绩")
brr = .Range("A1").CurrentRegion
ReDim crr(2 To UBound(brr), 1 To 3)
For i = 2 To UBound(brr)
r = d(brr(i, 10))
If r <> "" Then
crr(i, 1) = arr(r, 5)
crr(i, 2) = arr(r, 6)
If brr(i, 2) <> arr(r, 2) Then crr(i, 3) = arr(r, 2)
End If
Next
.[k2].Resize(i - 2, 3) = crr
End With
End Sub

复制代码

zhaogang1960 · 发表于 2013-12-29 22:07

请看附件

求助：成绩提取.rar (17.17 KB, 下载次数: 21)

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

向一张表中各行填加与另一张表对应的行号

评分