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

ahyyf

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

赵教师：就是这个效果。给您填麻烦了，谢谢。

ahyyf

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

赵老师：再次打扰您，有点不好意思。
还想请您再给加个条件，就更好了。
再次请求：
如果在第10列中出现表“2012年地生考试成绩”中没有的号，则在成绩中显示“无此号”，说明这个号在去年考试中没有这个号，是错误的。
如：第10列第5行   201201888，在后面的表中根本不存在这个号，所以是错号，提示“无此号”，以便核实。
求助：成绩提取.rar (21.26 KB, 下载次数: 2)

2013-12-30 16:54 上传

点击文件名下载附件

zhaogang1960

ahyyf 发表于 2013-12-30 16:54
赵老师：再次打扰您，有点不好意思。
还想请您再给加个条件，就更好了。
再次请求：

1. Sub Macro1()
   
2.     Dim arr, brr, crr(), d As Object, i&, r
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheets("2012年地生考试成绩").Range("A1").CurrentRegion
   
5.     For i = 2 To UBound(arr)
   
6.         d(arr(i, 1)) = i
   
7.     Next
   
8.     With Sheets("中考成绩")
   
9.         brr = .Range("A1").CurrentRegion
   
10.         ReDim crr(2 To UBound(brr), 1 To 3)
    
11.         For i = 2 To UBound(brr)
    
12.             r = d(brr(i, 10))
    
13.             If r <> "" Then
    
14.                 crr(i, 1) = arr(r, 5)
    
15.                 crr(i, 2) = arr(r, 6)
    
16.                 If brr(i, 2) <> arr(r, 2) Then crr(i, 3) = arr(r, 2)
    
17.             Else
    
18.                 crr(i, 1) = "无此号"
    
19.                 crr(i, 2) = "无此号"
    
20.             End If
    
21.         Next
    
22.         .[k2].Resize(i - 2, 3) = crr
    
23.     End With
    
24. End Sub
    

复制代码

zhaogang1960

请测试附件
求助：成绩提取.rar (18.68 KB, 下载次数: 23)

2013-12-30 17:02 上传

点击文件名下载附件

ahyyf

zhaogang1960 发表于 2013-12-30 17:02
请测试附件

有求必应，真的太感谢您了，祝您好运，效果非常好。