[已解决]感谢“老司机带带我”老师！解决了两表合并问题

zzh49

求助各位老师解决一两表合并问题，详情请见附件。
谢谢各位！ 数据合并.rar (12.11 KB, 下载次数: 8)

2017-2-17 09:11 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

老司机带带我

2017-2-18 20:57

应该是互补合并吧！

1. Sub 合并()
   
2.     Dim d As Object
   
3.     Dim i&, j&, n&, n1&, arr, brr, m&
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheet2
   
6.         n = .Cells(.Rows.Count, 1).End(xlUp).Row
   
7.         arr = .Range("B2:H" & n)
   
8.     End With
   
9.     With Sheet3
   
10.         n1 = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.         brr = .Range("B2:H" & n1)
    
12.     End With
    
13.     With Sheet1
    
14.         For i = 1 To n - 1
    
15.             If Not d.exists(arr(i, 1)) Then
    
16.                 m = m + 1
    
17.                 d.Add arr(i, 1), m
    
18.                 .Cells(m + 1, 1) = m
    
19.                 For j = 2 To 8
    
20.                     .Cells(m + 1, j) = arr(i, j - 1)
    
21.                 Next
    
22.             End If
    
23.         Next
    
24.         For i = 1 To n1 - 1
    
25.             If Not d.exists(brr(i, 1)) Then
    
26.                 m = m + 1
    
27.                 d.Add brr(i, 1), m
    
28.                 .Cells(m + 1, 1) = m
    
29.                 For j = 2 To 8
    
30.                     .Cells(m + 1, j) = brr(i, j - 1)
    
31.                 Next
    
32.             Else
    
33.                 x = d(brr(i, 1))
    
34.                 For j = 2 To 8
    
35.                     If .Cells(x + 1, j) = "" Then .Cells(x + 1, j) = brr(i, j - 1)
    
36.                 Next
    
37.             End If
    
38.         Next
    
39.     End With
    
40. End Sub

复制代码

跳转到最佳答案楼层

老司机带带我

问题描述的有点含糊不清，是直接将两个表进行行的合并就完事了，还是说表1和表2很多姓名对应的信息是互补的，需要将每个人的数据按最全互补合并？猜很累的！

老司机带带我

应该是互补合并吧！

1. Sub 合并()
   
2.     Dim d As Object
   
3.     Dim i&, j&, n&, n1&, arr, brr, m&
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheet2
   
6.         n = .Cells(.Rows.Count, 1).End(xlUp).Row
   
7.         arr = .Range("B2:H" & n)
   
8.     End With
   
9.     With Sheet3
   
10.         n1 = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.         brr = .Range("B2:H" & n1)
    
12.     End With
    
13.     With Sheet1
    
14.         For i = 1 To n - 1
    
15.             If Not d.exists(arr(i, 1)) Then
    
16.                 m = m + 1
    
17.                 d.Add arr(i, 1), m
    
18.                 .Cells(m + 1, 1) = m
    
19.                 For j = 2 To 8
    
20.                     .Cells(m + 1, j) = arr(i, j - 1)
    
21.                 Next
    
22.             End If
    
23.         Next
    
24.         For i = 1 To n1 - 1
    
25.             If Not d.exists(brr(i, 1)) Then
    
26.                 m = m + 1
    
27.                 d.Add brr(i, 1), m
    
28.                 .Cells(m + 1, 1) = m
    
29.                 For j = 2 To 8
    
30.                     .Cells(m + 1, j) = brr(i, j - 1)
    
31.                 Next
    
32.             Else
    
33.                 x = d(brr(i, 1))
    
34.                 For j = 2 To 8
    
35.                     If .Cells(x + 1, j) = "" Then .Cells(x + 1, j) = brr(i, j - 1)
    
36.                 Next
    
37.             End If
    
38.         Next
    
39.     End With
    
40. End Sub

复制代码

zzh49

老司机带带我老师您好！怨我问题描述得不清，是互补合并。您的代码完全解决了我的问题。
衷心的感谢！！！

老司机带带我

zzh49 发表于 2017-2-18 22:28
老司机带带我老师您好！怨我问题描述得不清，是互补合并。您的代码完全解决了我的问题。
衷心的感谢！！！

不客气，不过这个代码执行效率上我没太多的去考虑，回头有时间在看下是否可以提高速度！