如何按姓名合并两个工作表的数据？

nyxmq

蓝版主、蓝老师您好！感谢您的帮助！请问如果想把sheet1和sheet2（学生人数不同，人也不完全相同），如何按照姓名把数据合并到sheet3中，两表都有把信息合并一起的排在前面，只有一个表有的排在后面，把两表所有人汇总到sheet3中，实际人数很多1000多人，谢谢！sheet2有很多列，把这些列合并到右边。 初中学籍上报表.zip (131.09 KB, 下载次数: 15)

2014-7-19 08:41 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim d As Object
   
3.   Dim arr, brr
   
4.   Dim r%, i%
   
5.   Dim ws As Worksheet
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   With Worksheets("sheet1")
   
8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     arr = .Range("a2:f" & r)
   
10.   End With
    
11.   For i = 1 To UBound(arr)
    
12.     If Not d.Exists(arr(i, 1)) Then
    
13.       ReDim brr(1 To 9)
    
14.       For j = 1 To UBound(arr, 2)
    
15.         brr(j) = arr(i, j)
    
16.       Next
    
17.       brr(9) = 2
    
18.       d(arr(i, 1)) = brr
    
19.     End If
    
20.   Next
    
21.   
    
22.   With Worksheets("sheet2")
    
23.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
24.     arr = .Range("a2:c" & r)
    
25.   End With
    
26.   For i = 1 To UBound(arr)
    
27.     If d.Exists(arr(i, 1)) Then
    
28.       brr = d(arr(i, 1))
    
29.       brr(9) = 1
    
30.     Else
    
31.       ReDim brr(1 To 9)
    
32.       brr(1) = arr(i, 1)
    
33.       brr(9) = 3
    
34.     End If
    
35.     For j = 1 To 2
    
36.       brr(j + 6) = arr(i, j + 1)
    
37.     Next
    
38.     d(arr(i, 1)) = brr
    
39.   Next
    
40.   With Worksheets("sheet3")
    
41.     .UsedRange.Offset(1, 0).ClearContents
    
42.     .Range("a2").Resize(d.Count, 9) = Application.Transpose(Application.Transpose(d.Items))
    
43.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
44.     .Range("a1:i" & r).Sort key1:=.Range("i2"), order1:=xlAscending, header:=xlYes
    
45.     .Columns("i:i").Clear
    
46.   End With
    
47. End Sub
    

复制代码

chxw68

两表都有的排第一位，只有第一张表有的排第二位，只有第二张表有的排第三位。

nyxmq

chxw68 发表于 2014-7-19 09:06
两表都有的排第一位，只有第一张表有的排第二位，只有第二张表有的排第三位。

谢谢老师帮助！

chxw68

nyxmq 发表于 2014-7-19 09:42
谢谢老师帮助！

结果正确吗？

nyxmq

chxw68 发表于 2014-7-19 09:53
结果正确吗？

再次感谢您的帮助！能不能把表2的所有列即包括各科成绩合并一起，谢谢！

chxw68

nyxmq 发表于 2014-7-19 10:39
再次感谢您的帮助！能不能把表2的所有列即包括各科成绩合并一起，谢谢！

很简单，回家帮你做。

chxw68

1. Sub test()
   
2.   Dim d As Object
   
3.   Dim arr, brr
   
4.   Dim r%, i%
   
5.   Dim ws As Worksheet
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   With Worksheets("sheet1")
   
8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     arr = .Range("a2:f" & r)
   
10.   End With
    
11.   For i = 1 To UBound(arr)
    
12.     If Not d.Exists(arr(i, 1)) Then
    
13.       ReDim brr(1 To 16)
    
14.       For j = 1 To UBound(arr, 2)
    
15.         brr(j) = arr(i, j)
    
16.       Next
    
17.       brr(16) = 2
    
18.       d(arr(i, 1)) = brr
    
19.     End If
    
20.   Next
    
21.   
    
22.   With Worksheets("sheet2")
    
23.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
24.     arr = .Range("a2:j" & r)
    
25.   End With
    
26.   For i = 1 To UBound(arr)
    
27.     If d.Exists(arr(i, 1)) Then
    
28.       brr = d(arr(i, 1))
    
29.       brr(16) = 1
    
30.     Else
    
31.       ReDim brr(1 To 16)
    
32.       brr(1) = arr(i, 1)
    
33.       brr(16) = 3
    
34.     End If
    
35.     For j = 1 To 9
    
36.       brr(j + 6) = arr(i, j + 1)
    
37.     Next
    
38.     d(arr(i, 1)) = brr
    
39.   Next
    
40.   With Worksheets("sheet3")
    
41.     .UsedRange.Offset(1, 0).ClearContents
    
42.     .Range("a2").Resize(d.Count, 16) = Application.Transpose(Application.Transpose(d.Items))
    
43.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
44.     .Range("a1:p" & r).Sort key1:=.Range("p2"), order1:=xlAscending, header:=xlYes
    
45.     .Columns("p:p").Clear
    
46.   End With
    
47. End Sub
    

复制代码

chxw68

楼主Sheet2后面有很多重复数据，而且在成绩栏里填写的是学籍号和考号等数据，让我查找了很长时间才找出程序执行错误的原因。

nyxmq

chxw68 发表于 2014-7-19 16:47
楼主Sheet2后面有很多重复数据，而且在成绩栏里填写的是学籍号和考号等数据，让我查找了很长时间才找出程序 ...

谢谢！数据有些是临时复制的，给您添麻烦了。表3数据清空后运行宏怎么没有复制过来标题行？另外如果表2列更多可修改哪些代码？表2的数据添加到表3是从g列开始，如何随意更改位置如添加到h列或k列这样的话就可以随意增减表1和表2列的多少了？